diff --git a/src/HOL/Algebra/Finite_Extensions.thy b/src/HOL/Algebra/Finite_Extensions.thy
--- a/src/HOL/Algebra/Finite_Extensions.thy
+++ b/src/HOL/Algebra/Finite_Extensions.thy
@@ -1,726 +1,744 @@
 (*  Title:      HOL/Algebra/Finite_Extensions.thy
     Author:     Paulo Emílio de Vilhena
 *)
 
 theory Finite_Extensions
   imports Embedded_Algebras Polynomials Polynomial_Divisibility
     
 begin
 
 section \<open>Finite Extensions\<close>
 
 subsection \<open>Definitions\<close>
 
 definition (in ring) transcendental :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
   where "transcendental K x \<longleftrightarrow> inj_on (\<lambda>p. eval p x) (carrier (K[X]))"
 
 abbreviation (in ring) algebraic :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
   where "algebraic K x \<equiv> \<not> transcendental K x"
 
 definition (in ring) Irr :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a list"
   where "Irr K x = (THE p. p \<in> carrier (K[X]) \<and> pirreducible K p \<and> eval p x = \<zero> \<and> lead_coeff p = \<one>)"
 
 inductive_set (in ring) simple_extension :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a set"
   for K and x where
     zero [simp, intro]: "\<zero> \<in> simple_extension K x" |
     lin:  "\<lbrakk> k1 \<in> simple_extension K x; k2 \<in> K \<rbrakk> \<Longrightarrow> (k1 \<otimes> x) \<oplus> k2 \<in> simple_extension K x"
 
 fun (in ring) finite_extension :: "'a set \<Rightarrow> 'a list \<Rightarrow> 'a set"
   where "finite_extension K xs = foldr (\<lambda>x K'. simple_extension K' x) xs K"
 
 
 subsection \<open>Basic Properties\<close>
 
 lemma (in ring) transcendental_consistent:
   assumes "subring K R" shows "transcendental = ring.transcendental (R \<lparr> carrier := K \<rparr>)"
   unfolding transcendental_def ring.transcendental_def[OF subring_is_ring[OF assms]]
             univ_poly_consistent[OF assms] eval_consistent[OF assms] ..
 
 lemma (in ring) algebraic_consistent:
   assumes "subring K R" shows "algebraic = ring.algebraic (R \<lparr> carrier := K \<rparr>)"
   unfolding over_def transcendental_consistent[OF assms] ..
 
 lemma (in ring) eval_transcendental:
   assumes "(transcendental over K) x" "p \<in> carrier (K[X])" "eval p x = \<zero>" shows "p = []"
 proof -
   have "[] \<in> carrier (K[X])" and "eval [] x = \<zero>"
     by (auto simp add: univ_poly_def)
   thus ?thesis
     using assms unfolding over_def transcendental_def inj_on_def by auto
 qed
 
 lemma (in ring) transcendental_imp_trivial_ker:
   shows "(transcendental over K) x \<Longrightarrow> a_kernel (K[X]) R (\<lambda>p. eval p x) = { [] }"
   using eval_transcendental unfolding a_kernel_def' by (auto simp add: univ_poly_def)
 
 lemma (in ring) non_trivial_ker_imp_algebraic:
   shows "a_kernel (K[X]) R (\<lambda>p. eval p x) \<noteq> { [] } \<Longrightarrow> (algebraic over K) x"
   using transcendental_imp_trivial_ker unfolding over_def by auto
 
 lemma (in domain) trivial_ker_imp_transcendental:
   assumes "subring K R" and "x \<in> carrier R"
   shows "a_kernel (K[X]) R (\<lambda>p. eval p x) = { [] } \<Longrightarrow> (transcendental over K) x"
   using ring_hom_ring.trivial_ker_imp_inj[OF eval_ring_hom[OF assms]]
   unfolding transcendental_def over_def by (simp add: univ_poly_zero)
 
 lemma (in domain) algebraic_imp_non_trivial_ker:
   assumes "subring K R" and "x \<in> carrier R"
   shows "(algebraic over K) x \<Longrightarrow> a_kernel (K[X]) R (\<lambda>p. eval p x) \<noteq> { [] }"
   using trivial_ker_imp_transcendental[OF assms] unfolding over_def by auto
 
 lemma (in domain) algebraicE:
   assumes "subring K R" and "x \<in> carrier R" "(algebraic over K) x"
   obtains p where "p \<in> carrier (K[X])" "p \<noteq> []" "eval p x = \<zero>"
 proof -
   have "[] \<in> a_kernel (K[X]) R (\<lambda>p. eval p x)"
     unfolding a_kernel_def' univ_poly_def by auto
   then obtain p where "p \<in> carrier (K[X])" "p \<noteq> []" "eval p x = \<zero>"
     using algebraic_imp_non_trivial_ker[OF assms] unfolding a_kernel_def' by blast
   thus thesis using that by auto
 qed
 
 lemma (in ring) algebraicI:
   assumes "p \<in> carrier (K[X])" "p \<noteq> []" and "eval p x = \<zero>" shows "(algebraic over K) x"
   using assms non_trivial_ker_imp_algebraic unfolding a_kernel_def' by auto
 
 lemma (in ring) transcendental_mono:
   assumes "K \<subseteq> K'" "(transcendental over K') x" shows "(transcendental over K) x"
 proof -
   have "carrier (K[X]) \<subseteq> carrier (K'[X])"
     using assms(1) unfolding univ_poly_def polynomial_def by auto
   thus ?thesis
     using assms unfolding over_def transcendental_def by (metis inj_on_subset)
 qed
 
 corollary (in ring) algebraic_mono:
   assumes "K \<subseteq> K'" "(algebraic over K) x" shows "(algebraic over K') x"
   using transcendental_mono[OF assms(1)] assms(2) unfolding over_def by blast 
 
 lemma (in domain) zero_is_algebraic:
   assumes "subring K R" shows "(algebraic over K) \<zero>"
   using algebraicI[OF var_closed(1)[OF assms]] unfolding var_def by auto
 
 lemma (in domain) algebraic_self:
   assumes "subring K R" and "k \<in> K" shows "(algebraic over K) k"
 proof (rule algebraicI[of "[ \<one>, \<ominus> k ]"])
   show "[ \<one>, \<ominus> k ] \<in> carrier (K [X])" and "[ \<one>, \<ominus> k ] \<noteq> []"
     using subringE(2-3,5)[OF assms(1)] assms(2) unfolding univ_poly_def polynomial_def by auto
   have "k \<in> carrier R"
     using subringE(1)[OF assms(1)] assms(2) by auto
   thus "eval [ \<one>, \<ominus> k ] k = \<zero>"
     by (auto, algebra)
 qed
 
 lemma (in domain) ker_diff_carrier:
   assumes "subring K R"
   shows "a_kernel (K[X]) R (\<lambda>p. eval p x) \<noteq> carrier (K[X])"
 proof -
   have "eval [ \<one> ] x \<noteq> \<zero>" and "[ \<one> ] \<in> carrier (K[X])"
     using subringE(3)[OF assms] unfolding univ_poly_def polynomial_def by auto
   thus ?thesis
     unfolding a_kernel_def' by blast
 qed
 
 
 subsection \<open>Minimal Polynomial\<close>
 
 lemma (in domain) minimal_polynomial_is_unique:
   assumes "subfield K R" and "x \<in> carrier R" "(algebraic over K) x"
   shows "\<exists>!p \<in> carrier (K[X]). pirreducible K p \<and> eval p x = \<zero> \<and> lead_coeff p = \<one>"
     (is "\<exists>!p. ?minimal_poly p")
 proof -
   interpret UP: principal_domain "K[X]"
     using univ_poly_is_principal[OF assms(1)] .
 
   let ?ker_gen = "\<lambda>p. p \<in> carrier (K[X]) \<and> pirreducible K p \<and> lead_coeff p = \<one> \<and>
                     a_kernel (K[X]) R (\<lambda>p. eval p x) = PIdl\<^bsub>K[X]\<^esub> p"
 
   obtain p where p: "?ker_gen p" and unique: "\<And>q. ?ker_gen q \<Longrightarrow> q = p"
     using exists_unique_pirreducible_gen[OF assms(1) eval_ring_hom[OF _ assms(2)]
           algebraic_imp_non_trivial_ker[OF _ assms(2-3)]
           ker_diff_carrier] subfieldE(1)[OF assms(1)] by auto
   hence "?minimal_poly p"
     using UP.cgenideal_self p unfolding a_kernel_def' by auto
   moreover have "\<And>q. ?minimal_poly q \<Longrightarrow> q = p"
   proof -
     fix q assume q: "?minimal_poly q"
     then have "q \<in> PIdl\<^bsub>K[X]\<^esub> p"
       using p unfolding a_kernel_def' by auto
     hence "p \<sim>\<^bsub>K[X]\<^esub> q"
       using cgenideal_pirreducible[OF assms(1)] p q by simp
     hence "a_kernel (K[X]) R (\<lambda>p. eval p x) = PIdl\<^bsub>K[X]\<^esub> q"
       using UP.associated_iff_same_ideal q p by simp
     thus "q = p"
       using unique q by simp
   qed
   ultimately show ?thesis by blast
 qed
 
 lemma (in domain) IrrE:
   assumes "subfield K R" and "x \<in> carrier R" "(algebraic over K) x"
   shows "Irr K x \<in> carrier (K[X])" and "pirreducible K (Irr K x)"
     and "lead_coeff (Irr K x) = \<one>" and "eval (Irr K x) x = \<zero>"
   using theI'[OF minimal_polynomial_is_unique[OF assms]] unfolding Irr_def by auto
 
 lemma (in domain) Irr_generates_ker:
   assumes "subfield K R" and "x \<in> carrier R" "(algebraic over K) x"
   shows "a_kernel (K[X]) R (\<lambda>p. eval p x) = PIdl\<^bsub>K[X]\<^esub> (Irr K x)"
 proof -
   obtain q
     where q: "q \<in> carrier (K[X])" "pirreducible K q"
       and ker: "a_kernel (K[X]) R (\<lambda>p. eval p x) = PIdl\<^bsub>K[X]\<^esub> q"
     using exists_unique_pirreducible_gen[OF assms(1) eval_ring_hom[OF _ assms(2)]
           algebraic_imp_non_trivial_ker[OF _ assms(2-3)]
           ker_diff_carrier] subfieldE(1)[OF assms(1)] by auto
   have "Irr K x \<in> PIdl\<^bsub>K[X]\<^esub> q"
     using IrrE(1,4)[OF assms] ker unfolding a_kernel_def' by auto
   thus ?thesis
     using cgenideal_pirreducible[OF assms(1) q(1-2) IrrE(2)[OF assms]] q(1) IrrE(1)[OF assms]
           cring.associated_iff_same_ideal[OF univ_poly_is_cring[OF subfieldE(1)[OF assms(1)]]]
     unfolding ker
     by simp
 qed
 
 lemma (in domain) Irr_minimal:
   assumes "subfield K R" and "x \<in> carrier R" "(algebraic over K) x"
     and "p \<in> carrier (K[X])" "eval p x = \<zero>" shows "(Irr K x) pdivides p"
 proof -
   interpret UP: principal_domain "K[X]"
     using univ_poly_is_principal[OF assms(1)] .
 
   have "p \<in> PIdl\<^bsub>K[X]\<^esub> (Irr K x)"
     using Irr_generates_ker[OF assms(1-3)] assms(4-5) unfolding a_kernel_def' by auto
   hence "(Irr K x) divides\<^bsub>K[X]\<^esub> p"
     using UP.to_contain_is_to_divide IrrE(1)[OF assms(1-3)]
     by (meson UP.cgenideal_ideal UP.cgenideal_minimal assms(4))
   thus ?thesis
     unfolding pdivides_iff_shell[OF assms(1) IrrE(1)[OF assms(1-3)] assms(4)] .
 qed
 
 lemma (in domain) rupture_of_Irr:
   assumes "subfield K R" and "x \<in> carrier R" "(algebraic over K) x" shows "field (Rupt K (Irr K x))"
   using rupture_is_field_iff_pirreducible[OF assms(1)] IrrE(1-2)[OF assms] by simp
 
 
 subsection \<open>Simple Extensions\<close>
 
 lemma (in ring) simple_extension_consistent:
   assumes "subring K R" shows "ring.simple_extension (R \<lparr> carrier := K \<rparr>) = simple_extension"
 proof -
   interpret K: ring "R \<lparr> carrier := K \<rparr>"
     using subring_is_ring[OF assms] .
 
   have "\<And>K' x. K.simple_extension  K' x \<subseteq> simple_extension K' x"
   proof
     fix K' x a show "a \<in> K.simple_extension  K' x \<Longrightarrow> a \<in> simple_extension K' x"
       by (induction rule: K.simple_extension.induct) (auto simp add: simple_extension.lin)
   qed
   moreover
   have "\<And>K' x. simple_extension K' x \<subseteq> K.simple_extension  K' x"
   proof
     fix K' x a assume a: "a \<in> simple_extension K' x" thus "a \<in> K.simple_extension  K' x"
       using K.simple_extension.zero K.simple_extension.lin
       by (induction rule: simple_extension.induct) (simp)+
   qed
   ultimately show ?thesis by blast
 qed
 
 lemma (in ring) mono_simple_extension:
   assumes "K \<subseteq> K'" shows "simple_extension K x \<subseteq> simple_extension K' x"
 proof
   fix a assume "a \<in> simple_extension K x" thus "a \<in> simple_extension K' x"
   proof (induct a rule: simple_extension.induct, simp)
     case lin thus ?case using simple_extension.lin assms by blast
   qed
 qed
 
 lemma (in ring) simple_extension_incl:
   assumes "K \<subseteq> carrier R" and "x \<in> carrier R" shows "K \<subseteq> simple_extension K x"
 proof
   fix k assume "k \<in> K" thus "k \<in> simple_extension K x"
     using simple_extension.lin[OF simple_extension.zero, of k K x] assms by auto
 qed
 
 lemma (in ring) simple_extension_mem:
   assumes "subring K R" and "x \<in> carrier R" shows "x \<in> simple_extension K x"
 proof -
   have "\<one> \<in> simple_extension K x"
     using simple_extension_incl[OF _ assms(2)] subringE(1,3)[OF assms(1)] by auto
   thus ?thesis
     using simple_extension.lin[OF _ subringE(2)[OF assms(1)], of \<one> x] assms(2) by auto
 qed
 
 lemma (in ring) simple_extension_carrier:
   assumes "x \<in> carrier R" shows "simple_extension (carrier R) x = carrier R"
 proof
   show "carrier R \<subseteq> simple_extension (carrier R) x"
     using simple_extension_incl[OF _ assms] by auto
 next
   show "simple_extension (carrier R) x \<subseteq> carrier R"
   proof
     fix a assume "a \<in> simple_extension (carrier R) x" thus "a \<in> carrier R"
       by (induct a rule: simple_extension.induct) (auto simp add: assms)
   qed
 qed
 
 lemma (in ring) simple_extension_in_carrier:
   assumes "K \<subseteq> carrier R" and "x \<in> carrier R" shows "simple_extension K x \<subseteq> carrier R"
   using mono_simple_extension[OF assms(1), of x] simple_extension_carrier[OF assms(2)] by auto 
 
 lemma (in ring) simple_extension_subring_incl:
   assumes "subring K' R" and "K \<subseteq> K'" "x \<in> K'" shows "simple_extension K x \<subseteq> K'"
   using ring.simple_extension_in_carrier[OF subring_is_ring[OF assms(1)]] assms(2-3)
   unfolding simple_extension_consistent[OF assms(1)] by simp
 
 lemma (in ring) simple_extension_as_eval_img:
   assumes "K \<subseteq> carrier R" "x \<in> carrier R"
   shows "simple_extension K x = (\<lambda>p. eval p x) ` carrier (K[X])"
 proof
   show "simple_extension K x \<subseteq> (\<lambda>p. eval p x) ` carrier (K[X])"
   proof
     fix a assume "a \<in> simple_extension K x" thus "a \<in> (\<lambda>p. eval p x) ` carrier (K[X])"
     proof (induction rule: simple_extension.induct)
       case zero
       have "polynomial K []" and "eval [] x = \<zero>"
         unfolding polynomial_def by simp+
       thus ?case
         unfolding univ_poly_carrier by force
     next
       case (lin k1 k2)
       then obtain p where p: "p \<in> carrier (K[X])" "polynomial K p" "eval p x = k1"
         by (auto simp add: univ_poly_carrier)
       hence "set p \<subseteq> carrier R" and "k2 \<in> carrier R"
         using assms(1) lin(2) unfolding polynomial_def by auto
       hence "eval (normalize (p @ [ k2 ])) x = k1 \<otimes> x \<oplus> k2"
         using eval_append_aux[of p k2 x] eval_normalize[of "p @ [ k2 ]" x] assms(2) p(3) by auto
       moreover have "set (p @ [k2]) \<subseteq> K"
         using polynomial_incl[OF p(2)] \<open>k2 \<in> K\<close> by auto
       then have "local.normalize (p @ [k2]) \<in> carrier (K [X])"
         using normalize_gives_polynomial univ_poly_carrier by blast
       ultimately show ?case
         unfolding univ_poly_carrier by force
     qed
   qed
 next
   show "(\<lambda>p. eval p x) ` carrier (K[X]) \<subseteq> simple_extension K x"
   proof
     fix a assume "a \<in> (\<lambda>p. eval p x) ` carrier (K[X])"
     then obtain p where p: "set p \<subseteq> K" "eval p x = a"
       using polynomial_incl unfolding univ_poly_def by auto
     thus "a \<in> simple_extension K x"
     proof (induct "length p" arbitrary: p a)
       case 0 thus ?case
         using simple_extension.zero by simp
     next
       case (Suc n)
       obtain p' k where p: "p = p' @ [ k ]"
         using Suc(2) by (metis list.size(3) nat.simps(3) rev_exhaust)
       hence "a = (eval p' x) \<otimes> x \<oplus> k"
         using eval_append_aux[of p' k x] Suc(3-4) assms unfolding p by auto
       moreover have "eval p' x \<in> simple_extension K x"
         using Suc(1-3) unfolding p by auto
       ultimately show ?case
         using simple_extension.lin Suc(3) unfolding p by auto
     qed
   qed
 qed
 
 corollary (in domain) simple_extension_is_subring:
   assumes "subring K R" "x \<in> carrier R" shows "subring (simple_extension K x) R"
   using ring_hom_ring.img_is_subring[OF eval_ring_hom[OF assms]
         ring.carrier_is_subring[OF univ_poly_is_ring[OF assms(1)]]]
         simple_extension_as_eval_img[OF subringE(1)[OF assms(1)] assms(2)]
   by simp
 
 corollary (in domain) simple_extension_minimal:
   assumes "subring K R" "x \<in> carrier R"
   shows "simple_extension K x = \<Inter> { K'. subring K' R \<and> K \<subseteq> K' \<and> x \<in> K' }"
   using simple_extension_is_subring[OF assms] simple_extension_mem[OF assms]
         simple_extension_incl[OF subringE(1)[OF assms(1)] assms(2)] simple_extension_subring_incl
   by blast
 
 corollary (in domain) simple_extension_isomorphism:
   assumes "subring K R" "x \<in> carrier R"
   shows "(K[X]) Quot (a_kernel (K[X]) R (\<lambda>p. eval p x)) \<simeq> R \<lparr> carrier := simple_extension K x \<rparr>"
   using ring_hom_ring.FactRing_iso_set_aux[OF eval_ring_hom[OF assms]]
         simple_extension_as_eval_img[OF subringE(1)[OF assms(1)] assms(2)]
   unfolding is_ring_iso_def by auto
 
 corollary (in domain) simple_extension_of_algebraic:
   assumes "subfield K R" and "x \<in> carrier R" "(algebraic over K) x"
   shows "Rupt K (Irr K x) \<simeq> R \<lparr> carrier := simple_extension K x \<rparr>"
   using simple_extension_isomorphism[OF subfieldE(1)[OF assms(1)] assms(2)]
   unfolding Irr_generates_ker[OF assms] rupture_def by simp
 
 corollary (in domain) simple_extension_of_transcendental:
   assumes "subring K R" and "x \<in> carrier R" "(transcendental over K) x"
   shows "K[X] \<simeq> R \<lparr> carrier := simple_extension K x \<rparr>"
   using simple_extension_isomorphism[OF _ assms(2), of K] assms(1)
         ring_iso_trans[OF ring.FactRing_zeroideal(2)[OF univ_poly_is_ring]]
   unfolding transcendental_imp_trivial_ker[OF assms(3)] univ_poly_zero
   by auto
 
 proposition (in domain) simple_extension_subfield_imp_algebraic:
   assumes "subring K R" "x \<in> carrier R"
   shows "subfield (simple_extension K x) R \<Longrightarrow> (algebraic over K) x"
 proof -
   assume simple_ext: "subfield (simple_extension K x) R" show "(algebraic over K) x"
   proof (rule ccontr)
     assume "\<not> (algebraic over K) x" then have "(transcendental over K) x"
       unfolding over_def by simp
     then obtain h where h: "h \<in> ring_iso (R \<lparr> carrier := simple_extension K x \<rparr>) (K[X])"
       using ring_iso_sym[OF univ_poly_is_ring simple_extension_of_transcendental] assms
       unfolding is_ring_iso_def by blast
     then interpret Hom: ring_hom_ring "R \<lparr> carrier := simple_extension K x \<rparr>" "K[X]" h
       using subring_is_ring[OF simple_extension_is_subring[OF assms]]
             univ_poly_is_ring[OF assms(1)] assms h
       by (auto simp add: ring_hom_ring_def ring_hom_ring_axioms_def ring_iso_def)
     have "field (K[X])"
       using field.ring_iso_imp_img_field[OF subfield_iff(2)[OF simple_ext] h]
       unfolding Hom.hom_one Hom.hom_zero by simp
     moreover have "\<not> field (K[X])"
       using univ_poly_not_field[OF assms(1)] .
     ultimately show False by simp
   qed
 qed
 
 proposition (in domain) simple_extension_is_subfield:
   assumes "subfield K R" "x \<in> carrier R"
   shows "subfield (simple_extension K x) R \<longleftrightarrow> (algebraic over K) x"
 proof
   assume alg: "(algebraic over K) x"
   then obtain h where h: "h \<in> ring_iso (Rupt K (Irr K x)) (R \<lparr> carrier := simple_extension K x \<rparr>)"
     using simple_extension_of_algebraic[OF assms] unfolding is_ring_iso_def by blast
   have rupt_field: "field (Rupt K (Irr K x))" and "ring (R \<lparr> carrier := simple_extension K x \<rparr>)"
     using subring_is_ring[OF simple_extension_is_subring[OF subfieldE(1)]]
           rupture_of_Irr[OF assms alg] assms by simp+
   then interpret Hom: ring_hom_ring "Rupt K (Irr K x)" "R \<lparr> carrier := simple_extension K x \<rparr>" h
     using h cring.axioms(1)[OF domain.axioms(1)[OF field.axioms(1)]]
     by (auto simp add: ring_hom_ring_def ring_hom_ring_axioms_def ring_iso_def)
   show "subfield (simple_extension K x) R"
     using field.ring_iso_imp_img_field[OF rupt_field h] subfield_iff(1)[OF _
           simple_extension_in_carrier[OF subfieldE(3)[OF assms(1)] assms(2)]]
     by simp
 next
   assume simple_ext: "subfield (simple_extension K x) R" thus "(algebraic over K) x"
     using simple_extension_subfield_imp_algebraic[OF subfieldE(1)[OF assms(1)] assms(2)] by simp
 qed
 
 
 subsection \<open>Link between dimension of K-algebras and algebraic extensions\<close>
 
 lemma (in domain) exp_base_independent:
   assumes "subfield K R" "x \<in> carrier R" "(algebraic over K) x"
   shows "independent K (exp_base x (degree (Irr K x)))"
 proof -
   have "\<And>n. n \<le> degree (Irr K x) \<Longrightarrow> independent K (exp_base x n)"
   proof -
     fix n show "n \<le> degree (Irr K x) \<Longrightarrow> independent K (exp_base x n)"
     proof (induct n, simp add: exp_base_def)
       case (Suc n)
       have "x [^] n \<notin> Span K (exp_base x n)"
       proof (rule ccontr)
         assume "\<not> x [^] n \<notin> Span K (exp_base x n)"
         then obtain a Ks
           where Ks: "a \<in> K - { \<zero> }" "set Ks \<subseteq> K" "length Ks = n" "combine (a # Ks) (exp_base x (Suc n)) = \<zero>"
           using Span_mem_imp_non_trivial_combine[OF assms(1) exp_base_closed[OF assms(2), of n]]
           by (auto simp add: exp_base_def)
         hence "eval (a # Ks) x = \<zero>"
           using combine_eq_eval by (auto simp add: exp_base_def)
         moreover have "(a # Ks) \<in> carrier (K[X]) - { [] }"
           unfolding univ_poly_def polynomial_def using Ks(1-2) by auto
         ultimately have "degree (Irr K x) \<le> n"
           using pdivides_imp_degree_le[OF subfieldE(1)[OF assms(1)]
                 IrrE(1)[OF assms] _ _  Irr_minimal[OF assms, of "a # Ks"]] Ks(3) by auto
         from \<open>Suc n \<le> degree (Irr K x)\<close> and this show False by simp
       qed
       thus ?case
         using independent.li_Cons assms(2) Suc by (auto simp add: exp_base_def)
     qed
   qed
   thus ?thesis
     by simp
 qed
 
 lemma (in ring) Span_eq_eval_img:
   assumes "subfield K R" "x \<in> carrier R"
   shows "Span K (exp_base x n) = (\<lambda>p. eval p x) ` { p \<in> carrier (K[X]). length p \<le> n }"
     (is "?Span = ?eval_img")
 proof
   show "?Span \<subseteq> ?eval_img"
   proof
     fix u assume "u \<in> Span K (exp_base x n)"
     then obtain Ks where Ks: "set Ks \<subseteq> K" "length Ks = n" "u = combine Ks (exp_base x n)"
       using Span_eq_combine_set_length_version[OF assms(1) exp_base_closed[OF assms(2)]]
       by (auto simp add: exp_base_def)
     hence "u = eval (normalize Ks) x"
       using combine_eq_eval eval_normalize[OF _ assms(2)] subfieldE(3)[OF assms(1)] by auto
     moreover have "normalize Ks \<in> carrier (K[X])"
       using normalize_gives_polynomial[OF Ks(1)] unfolding univ_poly_def by auto
     moreover have "length (normalize Ks) \<le> n"
       using normalize_length_le[of Ks] Ks(2) by auto
     ultimately show "u \<in> ?eval_img" by auto
   qed
 next
   show "?eval_img \<subseteq> ?Span"
   proof
     fix u assume "u \<in> ?eval_img"
     then obtain p where p: "p \<in> carrier (K[X])" "length p \<le> n" "u = eval p x"
       by blast
     hence "combine p (exp_base x (length p)) = u"
       using combine_eq_eval by auto
     moreover have set_p: "set p \<subseteq> K"
       using polynomial_incl[of K p] p(1) unfolding univ_poly_carrier by auto
     hence "set p \<subseteq> carrier R"
       using subfieldE(3)[OF assms(1)] by auto 
     moreover have "drop (n - length p) (exp_base x n) = exp_base x (length p)"
       using p(2) drop_exp_base by auto
     ultimately have "combine ((replicate (n - length p) \<zero>) @ p) (exp_base x n) = u"
       using combine_prepend_replicate[OF _ exp_base_closed[OF assms(2), of n]] by auto
     moreover have "set ((replicate (n - length p) \<zero>) @ p) \<subseteq> K"
       using subringE(2)[OF subfieldE(1)[OF assms(1)]] set_p by auto
     ultimately show "u \<in> ?Span"
       using Span_eq_combine_set[OF assms(1) exp_base_closed[OF assms(2), of n]] by blast
   qed
 qed
 
 lemma (in domain) Span_exp_base:
   assumes "subfield K R" "x \<in> carrier R" "(algebraic over K) x"
   shows "Span K (exp_base x (degree (Irr K x))) = simple_extension K x"
   unfolding simple_extension_as_eval_img[OF subfieldE(3)[OF assms(1)] assms(2)]
             Span_eq_eval_img[OF assms(1-2)]
 proof (auto)
   interpret UP: principal_domain "K[X]"
     using univ_poly_is_principal[OF assms(1)] .
   note hom_simps = ring_hom_memE[OF eval_is_hom[OF subfieldE(1)[OF assms(1)] assms(2)]]
 
   fix p assume p: "p \<in> carrier (K[X])"
   have Irr: "Irr K x \<in> carrier (K[X])" "Irr K x \<noteq> []"
     using IrrE(1-2)[OF assms] unfolding ring_irreducible_def univ_poly_zero by auto 
   then obtain q r
     where q: "q \<in> carrier (K[X])" and r: "r \<in> carrier (K[X])"
       and dvd: "p = Irr K x \<otimes>\<^bsub>K [X]\<^esub> q \<oplus>\<^bsub>K [X]\<^esub> r" "r = [] \<or> degree r < degree (Irr K x)"
     using subfield_long_division_theorem_shell[OF assms(1) p Irr(1)] unfolding univ_poly_zero by auto
   hence "eval p x = (eval (Irr K x) x) \<otimes> (eval q x) \<oplus> (eval r x)"
     using hom_simps(2-3) Irr(1) by simp
   hence "eval p x = eval r x"
     using hom_simps(1) q r unfolding IrrE(4)[OF assms] by simp
   moreover have "length r < length (Irr K x)"
     using dvd(2) Irr(2) by auto
   ultimately
   show "eval p x \<in> (\<lambda>p. local.eval p x) ` { p \<in> carrier (K [X]). length p \<le> length (Irr K x) - Suc 0 }"
     using r by auto
 qed
 
 corollary (in domain) dimension_simple_extension:
   assumes "subfield K R" "x \<in> carrier R" "(algebraic over K) x"
   shows "dimension (degree (Irr K x)) K (simple_extension K x)"
   using dimension_independent[OF exp_base_independent[OF assms]] Span_exp_base[OF assms]
   by (simp add: exp_base_def)
 
 lemma (in ring) finite_dimension_imp_algebraic:
   assumes "subfield K R" "subring F R" and "finite_dimension K F"
   shows "x \<in> F \<Longrightarrow> (algebraic over K) x"
 proof -
   let ?Us = "\<lambda>n. map (\<lambda>i. x [^] i) (rev [0..< Suc n])"
 
   assume x: "x \<in> F" then have in_carrier: "x \<in> carrier R"
     using subringE[OF assms(2)] by auto
   obtain n where n: "dimension n K F"
     using assms(3) by auto
   have set_Us: "set (?Us n) \<subseteq> F"
     using x subringE(3,6)[OF assms(2)] by (induct n) (auto)
   hence "set (?Us n) \<subseteq> carrier R"
     using subringE(1)[OF assms(2)] by auto
   moreover have "dependent K (?Us n)"
     using independent_length_le_dimension[OF assms(1) n _ set_Us] by auto
   ultimately
   obtain Ks where Ks: "length Ks = Suc n" "combine Ks (?Us n) = \<zero>" "set Ks \<subseteq> K" "set Ks \<noteq> { \<zero> }"
     using dependent_imp_non_trivial_combine[OF assms(1), of "?Us n"] by auto
   have "set Ks \<subseteq> carrier R"
     using subring_props(1)[OF assms(1)] Ks(3) by auto 
   hence "eval (normalize Ks) x = \<zero>"
     using combine_eq_eval[of Ks] eval_normalize[OF _ in_carrier] Ks(1-2) by (simp add: exp_base_def)
   moreover have "normalize Ks = [] \<Longrightarrow> set Ks \<subseteq> { \<zero> }"
     by (induct Ks) (auto, meson list.discI,
                     metis all_not_in_conv list.discI list.sel(3) singletonD subset_singletonD)
   hence "normalize Ks \<noteq> []"
     using Ks(1,4) by (metis list.size(3) nat.distinct(1) set_empty subset_singleton_iff)
   moreover have "normalize Ks \<in> carrier (K[X])"
     using normalize_gives_polynomial[OF Ks(3)] unfolding univ_poly_def by auto
   ultimately show ?thesis
     using algebraicI by auto
 qed
 
 corollary (in domain) simple_extension_dim:
   assumes "subfield K R" "x \<in> carrier R" "(algebraic over K) x"
   shows "(dim over K) (simple_extension K x) = degree (Irr K x)"
   using dimI[OF assms(1) dimension_simple_extension[OF assms]] .
 
 corollary (in domain) finite_dimension_simple_extension:
   assumes "subfield K R" "x \<in> carrier R"
   shows "finite_dimension K (simple_extension K x) \<longleftrightarrow> (algebraic over K) x"
   using finite_dimensionI[OF dimension_simple_extension[OF assms]]
         finite_dimension_imp_algebraic[OF _ simple_extension_is_subring[OF subfieldE(1)]]
         simple_extension_mem[OF subfieldE(1)] assms
   by auto
 
 
 subsection \<open>Finite Extensions\<close>
 
 lemma (in ring) finite_extension_consistent:
   assumes "subring K R" shows "ring.finite_extension (R \<lparr> carrier := K \<rparr>) = finite_extension"
 proof -
   have "\<And>K' xs. ring.finite_extension (R \<lparr> carrier := K \<rparr>) K' xs = finite_extension K' xs"
   proof -
     fix K' xs show "ring.finite_extension (R \<lparr> carrier := K \<rparr>) K' xs = finite_extension K' xs"
       using ring.finite_extension.simps[OF subring_is_ring[OF assms]]
             simple_extension_consistent[OF assms] by (induct xs) (auto)
   qed
   thus ?thesis by blast
 qed
 
 lemma (in ring) mono_finite_extension:
   assumes "K \<subseteq> K'" shows "finite_extension K xs \<subseteq> finite_extension K' xs"
   using mono_simple_extension assms by (induct xs) (auto)
 
 lemma (in ring) finite_extension_carrier:
   assumes "set xs \<subseteq> carrier R" shows "finite_extension (carrier R) xs = carrier R"
   using assms simple_extension_carrier by (induct xs) (auto)
 
 lemma (in ring) finite_extension_in_carrier:
   assumes "K \<subseteq> carrier R" and "set xs \<subseteq> carrier R" shows "finite_extension K xs \<subseteq> carrier R"
   using assms simple_extension_in_carrier by (induct xs) (auto)
 
 lemma (in ring) finite_extension_subring_incl:
   assumes "subring K' R" and "K \<subseteq> K'" "set xs \<subseteq> K'" shows "finite_extension K xs \<subseteq> K'"
   using ring.finite_extension_in_carrier[OF subring_is_ring[OF assms(1)]] assms(2-3)
   unfolding finite_extension_consistent[OF assms(1)] by simp
 
 lemma (in ring) finite_extension_incl_aux:
   assumes "K \<subseteq> carrier R" and "x \<in> carrier R" "set xs \<subseteq> carrier R"
   shows "finite_extension K xs \<subseteq> finite_extension K (x # xs)"
   using simple_extension_incl[OF finite_extension_in_carrier[OF assms(1,3)] assms(2)] by simp
 
 lemma (in ring) finite_extension_incl:
   assumes "K \<subseteq> carrier R" and "set xs \<subseteq> carrier R" shows "K \<subseteq> finite_extension K xs"
   using finite_extension_incl_aux[OF assms(1)] assms(2) by (induct xs) (auto)
 
 lemma (in ring) finite_extension_as_eval_img:
   assumes "K \<subseteq> carrier R" and "x \<in> carrier R" "set xs \<subseteq> carrier R"
   shows "finite_extension K (x # xs) = (\<lambda>p. eval p x) ` carrier ((finite_extension K xs) [X])"
   using simple_extension_as_eval_img[OF finite_extension_in_carrier[OF assms(1,3)] assms(2)] by simp
 
 lemma (in domain) finite_extension_is_subring:
   assumes "subring K R" "set xs \<subseteq> carrier R" shows "subring (finite_extension K xs) R"
   using assms simple_extension_is_subring by (induct xs) (auto)
 
 corollary (in domain) finite_extension_mem:
-  assumes "subring K R" "set xs \<subseteq> carrier R" shows "set xs \<subseteq> finite_extension K xs"
-proof -
-  { fix x xs assume "x \<in> carrier R" "set xs \<subseteq> carrier R"
-    hence "x \<in> finite_extension K (x # xs)"
-      using simple_extension_mem[OF finite_extension_is_subring[OF assms(1), of xs]] by simp }
-  note aux_lemma = this
-  show ?thesis
-    using aux_lemma finite_extension_incl_aux[OF subringE(1)[OF assms(1)]] assms(2)
-    by (induct xs) (simp, smt insert_subset list.simps(15) subset_trans) 
+  assumes subring: "subring K R"
+  shows "set xs \<subseteq> carrier R \<Longrightarrow> set xs \<subseteq> finite_extension K xs"
+proof (induct xs)
+  case Nil
+  then show ?case by simp
+next
+  case (Cons a xs)
+  from Cons(2) have a: "a \<in> carrier R" and xs: "set xs \<subseteq> carrier R" by auto
+  show ?case
+  proof
+    fix x assume "x \<in> set (a # xs)"
+    then consider "x = a" | "x \<in> set xs" by auto
+    then show "x \<in> finite_extension K (a # xs)"
+    proof cases
+      case 1
+      with a have "x \<in> carrier R" by simp
+      with xs have "x \<in> finite_extension K (x # xs)"
+        using simple_extension_mem[OF finite_extension_is_subring[OF subring]] by simp
+      with 1 show ?thesis by simp
+    next
+      case 2
+      with Cons have *: "x \<in> finite_extension K xs" by auto
+      from a xs have "finite_extension K xs \<subseteq> finite_extension K (a # xs)"
+        by (rule finite_extension_incl_aux[OF subringE(1)[OF subring]])
+      with * show ?thesis by auto
+    qed
+  qed
 qed
 
 corollary (in domain) finite_extension_minimal:
   assumes "subring K R" "set xs \<subseteq> carrier R"
   shows "finite_extension K xs = \<Inter> { K'. subring K' R \<and> K \<subseteq> K' \<and> set xs \<subseteq> K' }"
   using finite_extension_is_subring[OF assms] finite_extension_mem[OF assms]
         finite_extension_incl[OF subringE(1)[OF assms(1)] assms(2)] finite_extension_subring_incl
   by blast
 
 corollary (in domain) finite_extension_same_set:
   assumes "subring K R" "set xs \<subseteq> carrier R" "set xs = set ys"
   shows "finite_extension K xs = finite_extension K ys"
   using finite_extension_minimal[OF assms(1)] assms(2-3) by auto
 
 text \<open>The reciprocal is also true, but it is more subtle.\<close>
 proposition (in domain) finite_extension_is_subfield:
   assumes "subfield K R" "set xs \<subseteq> carrier R"
   shows "(\<And>x. x \<in> set xs \<Longrightarrow> (algebraic over K) x) \<Longrightarrow> subfield (finite_extension K xs) R"
   using simple_extension_is_subfield algebraic_mono assms
   by (induct xs) (auto, metis finite_extension.simps finite_extension_incl subring_props(1))
 
 proposition (in domain) finite_extension_finite_dimension:
   assumes "subfield K R" "set xs \<subseteq> carrier R"
   shows "(\<And>x. x \<in> set xs \<Longrightarrow> (algebraic over K) x) \<Longrightarrow> finite_dimension K (finite_extension K xs)"
     and "finite_dimension K (finite_extension K xs) \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> (algebraic over K) x)"
 proof -
   show "finite_dimension K (finite_extension K xs) \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> (algebraic over K) x)"
     using finite_dimension_imp_algebraic[OF assms(1)
           finite_extension_is_subring[OF subfieldE(1)[OF assms(1)] assms(2)]]
           finite_extension_mem[OF subfieldE(1)[OF assms(1)] assms(2)] by auto
 next
   show "(\<And>x. x \<in> set xs \<Longrightarrow> (algebraic over K) x) \<Longrightarrow> finite_dimension K (finite_extension K xs)"
     using assms(2)
   proof (induct xs, simp add: finite_dimensionI[OF dimension_one[OF assms(1)]])
     case (Cons x xs)
     hence "finite_dimension K (finite_extension K xs)"
       by auto
     moreover have "(algebraic over (finite_extension K xs)) x"
       using algebraic_mono[OF finite_extension_incl[OF subfieldE(3)[OF assms(1)]]] Cons(2-3) by auto
     moreover have "subfield (finite_extension K xs) R"
       using finite_extension_is_subfield[OF assms(1)] Cons(2-3) by auto
     ultimately show ?case
       using telescopic_base_dim(1)[OF assms(1) _ _ 
             finite_dimensionI[OF dimension_simple_extension, of _ x]] Cons(3) by auto
   qed
 qed
 
 corollary (in domain) finite_extesion_mem_imp_algebraic:
   assumes "subfield K R" "set xs \<subseteq> carrier R" and "\<And>x. x \<in> set xs \<Longrightarrow> (algebraic over K) x"
   shows "y \<in> finite_extension K xs \<Longrightarrow> (algebraic over K) y"
   using finite_dimension_imp_algebraic[OF assms(1)
         finite_extension_is_subring[OF subfieldE(1)[OF assms(1)] assms(2)]]
         finite_extension_finite_dimension(1)[OF assms(1-2)] assms(3) by auto
 
 corollary (in domain) simple_extesion_mem_imp_algebraic:
   assumes "subfield K R" "x \<in> carrier R" "(algebraic over K) x"
   shows "y \<in> simple_extension K x \<Longrightarrow> (algebraic over K) y"
   using finite_extesion_mem_imp_algebraic[OF assms(1), of "[ x ]"] assms(2-3) by auto
 
 
 subsection \<open>Arithmetic of algebraic numbers\<close>
 
 text \<open>We show that the set of algebraic numbers of a field
       over a subfield K is a subfield itself.\<close>
 
 lemma (in field) subfield_of_algebraics:
   assumes "subfield K R" shows "subfield { x \<in> carrier R. (algebraic over K) x } R"
 proof -
   let ?set_of_algebraics = "{ x \<in> carrier R. (algebraic over K) x }"
 
   show ?thesis
   proof (rule subfieldI'[OF subringI])
     show "?set_of_algebraics \<subseteq> carrier R" and "\<one> \<in> ?set_of_algebraics"
       using algebraic_self[OF _ subringE(3)] subfieldE(1)[OF assms(1)] by auto
   next
     fix x y assume x: "x \<in> ?set_of_algebraics" and y: "y \<in> ?set_of_algebraics"
     have "\<ominus> x \<in> simple_extension K x"
       using subringE(5)[OF simple_extension_is_subring[OF subfieldE(1)]]
             simple_extension_mem[OF subfieldE(1)] assms(1) x by auto
     thus "\<ominus> x \<in> ?set_of_algebraics"
       using simple_extesion_mem_imp_algebraic[OF assms] x by auto
 
     have "x \<oplus> y \<in> finite_extension K [ x, y ]" and "x \<otimes> y \<in> finite_extension K [ x, y ]"
       using subringE(6-7)[OF finite_extension_is_subring[OF subfieldE(1)[OF assms(1)]], of "[ x, y ]"]
             finite_extension_mem[OF subfieldE(1)[OF assms(1)], of "[ x, y ]"] x y by auto
     thus "x \<oplus> y \<in> ?set_of_algebraics" and "x \<otimes> y \<in> ?set_of_algebraics"
       using finite_extesion_mem_imp_algebraic[OF assms, of "[ x, y ]"] x y by auto
   next
     fix z assume z: "z \<in> ?set_of_algebraics - { \<zero> }"
     have "inv z \<in> simple_extension K z"
       using subfield_m_inv(1)[of "simple_extension K z"]
             simple_extension_is_subfield[OF assms, of z]
             simple_extension_mem[OF subfieldE(1)] assms(1) z by auto
     thus "inv z \<in> ?set_of_algebraics"
       using simple_extesion_mem_imp_algebraic[OF assms] field_Units z by auto
   qed
 qed
 
 end
\ No newline at end of file
diff --git a/src/HOL/Data_Structures/Interval_Tree.thy b/src/HOL/Data_Structures/Interval_Tree.thy
--- a/src/HOL/Data_Structures/Interval_Tree.thy
+++ b/src/HOL/Data_Structures/Interval_Tree.thy
@@ -1,301 +1,301 @@
 (* Author: Bohua Zhan, with modifications by Tobias Nipkow *)
 
 section \<open>Interval Trees\<close>
 
 theory Interval_Tree
 imports
   "HOL-Data_Structures.Cmp"
   "HOL-Data_Structures.List_Ins_Del"
   "HOL-Data_Structures.Isin2"
   "HOL-Data_Structures.Set_Specs"
 begin
 
 subsection \<open>Intervals\<close>
 
 text \<open>The following definition of intervals uses the \<^bold>\<open>typedef\<close> command
 to define the type of non-empty intervals as a subset of the type of pairs \<open>p\<close>
 where @{prop "fst p \<le> snd p"}:\<close>
 
 typedef (overloaded) 'a::linorder ivl =
   "{p :: 'a \<times> 'a. fst p \<le> snd p}" by auto
 
 text \<open>More precisely, @{typ "'a ivl"} is isomorphic with that subset via the function
 @{const Rep_ivl}. Hence the basic interval properties are not immediate but
 need simple proofs:\<close>
 
 definition low :: "'a::linorder ivl \<Rightarrow> 'a" where
 "low p = fst (Rep_ivl p)"
 
 definition high :: "'a::linorder ivl \<Rightarrow> 'a" where
 "high p = snd (Rep_ivl p)"
 
 lemma ivl_is_interval: "low p \<le> high p"
 by (metis Rep_ivl high_def low_def mem_Collect_eq)
 
 lemma ivl_inj: "low p = low q \<Longrightarrow> high p = high q \<Longrightarrow> p = q"
 by (metis Rep_ivl_inverse high_def low_def prod_eqI)
 
 text \<open>Now we can forget how exactly intervals were defined.\<close>
 
 
 instantiation ivl :: (linorder) linorder begin
 
 definition ivl_less: "(x < y) = (low x < low y | (low x = low y \<and> high x < high y))"
 definition ivl_less_eq: "(x \<le> y) = (low x < low y | (low x = low y \<and> high x \<le> high y))"
 
 instance proof
   fix x y z :: "'a ivl"
   show a: "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     using ivl_less ivl_less_eq by force
   show b: "x \<le> x"
     by (simp add: ivl_less_eq)
   show c: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
-    by (smt ivl_less_eq dual_order.trans less_trans)
+    using ivl_less_eq by fastforce
   show d: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
     using ivl_less_eq a ivl_inj ivl_less by fastforce
   show e: "x \<le> y \<or> y \<le> x"
     by (meson ivl_less_eq leI not_less_iff_gr_or_eq)
 qed end
 
 
 definition overlap :: "('a::linorder) ivl \<Rightarrow> 'a ivl \<Rightarrow> bool" where
 "overlap x y \<longleftrightarrow> (high x \<ge> low y \<and> high y \<ge> low x)"
 
 definition has_overlap :: "('a::linorder) ivl set \<Rightarrow> 'a ivl \<Rightarrow> bool" where
 "has_overlap S y \<longleftrightarrow> (\<exists>x\<in>S. overlap x y)"
 
 
 subsection \<open>Interval Trees\<close>
 
 type_synonym 'a ivl_tree = "('a ivl * 'a) tree"
 
 fun max_hi :: "('a::order_bot) ivl_tree \<Rightarrow> 'a" where
 "max_hi Leaf = bot" |
 "max_hi (Node _ (_,m) _) = m"
 
 definition max3 :: "('a::linorder) ivl \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
 "max3 a m n = max (high a) (max m n)"
 
 fun inv_max_hi :: "('a::{linorder,order_bot}) ivl_tree \<Rightarrow> bool" where
 "inv_max_hi Leaf \<longleftrightarrow> True" |
 "inv_max_hi (Node l (a, m) r) \<longleftrightarrow> (m = max3 a (max_hi l) (max_hi r) \<and> inv_max_hi l \<and> inv_max_hi r)"
 
 lemma max_hi_is_max:
   "inv_max_hi t \<Longrightarrow> a \<in> set_tree t \<Longrightarrow> high a \<le> max_hi t"
 by (induct t, auto simp add: max3_def max_def)
 
 lemma max_hi_exists:
   "inv_max_hi t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> \<exists>a\<in>set_tree t. high a = max_hi t"
 proof (induction t rule: tree2_induct)
   case Leaf
   then show ?case by auto
 next
   case N: (Node l v m r)
   then show ?case
   proof (cases l rule: tree2_cases)
     case Leaf
     then show ?thesis
       using N.prems(1) N.IH(2) by (cases r, auto simp add: max3_def max_def le_bot)
   next
     case Nl: Node
     then show ?thesis
     proof (cases r rule: tree2_cases)
       case Leaf
       then show ?thesis
         using N.prems(1) N.IH(1) Nl by (auto simp add: max3_def max_def le_bot)
     next
       case Nr: Node
       obtain p1 where p1: "p1 \<in> set_tree l" "high p1 = max_hi l"
         using N.IH(1) N.prems(1) Nl by auto
       obtain p2 where p2: "p2 \<in> set_tree r" "high p2 = max_hi r"
         using N.IH(2) N.prems(1) Nr by auto
       then show ?thesis
         using p1 p2 N.prems(1) by (auto simp add: max3_def max_def)
     qed
   qed
 qed
 
 
 subsection \<open>Insertion and Deletion\<close>
 
 definition node where
 [simp]: "node l a r = Node l (a, max3 a (max_hi l) (max_hi r)) r"
 
 fun insert :: "'a::{linorder,order_bot} ivl \<Rightarrow> 'a ivl_tree \<Rightarrow> 'a ivl_tree" where
 "insert x Leaf = Node Leaf (x, high x) Leaf" |
 "insert x (Node l (a, m) r) =
   (case cmp x a of
      EQ \<Rightarrow> Node l (a, m) r |
      LT \<Rightarrow> node (insert x l) a r |
      GT \<Rightarrow> node l a (insert x r))"
 
 lemma inorder_insert:
   "sorted (inorder t) \<Longrightarrow> inorder (insert x t) = ins_list x (inorder t)"
 by (induct t rule: tree2_induct) (auto simp: ins_list_simps)
 
 lemma inv_max_hi_insert:
   "inv_max_hi t \<Longrightarrow> inv_max_hi (insert x t)"
 by (induct t rule: tree2_induct) (auto simp add: max3_def)
 
 fun split_min :: "'a::{linorder,order_bot} ivl_tree \<Rightarrow> 'a ivl \<times> 'a ivl_tree" where
 "split_min (Node l (a, m) r) =
   (if l = Leaf then (a, r)
    else let (x,l') = split_min l in (x, node l' a r))"
 
 fun delete :: "'a::{linorder,order_bot} ivl \<Rightarrow> 'a ivl_tree \<Rightarrow> 'a ivl_tree" where
 "delete x Leaf = Leaf" |
 "delete x (Node l (a, m) r) =
   (case cmp x a of
      LT \<Rightarrow> node (delete x l) a r |
      GT \<Rightarrow> node l a (delete x r) |
      EQ \<Rightarrow> if r = Leaf then l else
            let (a', r') = split_min r in node l a' r')"
 
 lemma split_minD:
   "split_min t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x # inorder t' = inorder t"
 by (induct t arbitrary: t' rule: split_min.induct)
    (auto simp: sorted_lems split: prod.splits if_splits)
 
 lemma inorder_delete:
   "sorted (inorder t) \<Longrightarrow> inorder (delete x t) = del_list x (inorder t)"
 by (induct t)
    (auto simp: del_list_simps split_minD Let_def split: prod.splits)
 
 lemma inv_max_hi_split_min:
   "\<lbrakk> t \<noteq> Leaf;  inv_max_hi t \<rbrakk> \<Longrightarrow> inv_max_hi (snd (split_min t))"
 by (induct t) (auto split: prod.splits)
 
 lemma inv_max_hi_delete:
   "inv_max_hi t \<Longrightarrow> inv_max_hi (delete x t)"
 apply (induct t)
  apply simp
 using inv_max_hi_split_min by (fastforce simp add: Let_def split: prod.splits)
 
 
 subsection \<open>Search\<close>
 
 text \<open>Does interval \<open>x\<close> overlap with any interval in the tree?\<close>
 
 fun search :: "'a::{linorder,order_bot} ivl_tree \<Rightarrow> 'a ivl \<Rightarrow> bool" where
 "search Leaf x = False" |
 "search (Node l (a, m) r) x =
   (if overlap x a then True
    else if l \<noteq> Leaf \<and> max_hi l \<ge> low x then search l x
    else search r x)"
 
 lemma search_correct:
   "inv_max_hi t \<Longrightarrow> sorted (inorder t) \<Longrightarrow> search t x = has_overlap (set_tree t) x"
 proof (induction t rule: tree2_induct)
   case Leaf
   then show ?case by (auto simp add: has_overlap_def)
 next
   case (Node l a m r)
   have search_l: "search l x = has_overlap (set_tree l) x"
     using Node.IH(1) Node.prems by (auto simp: sorted_wrt_append)
   have search_r: "search r x = has_overlap (set_tree r) x"
     using Node.IH(2) Node.prems by (auto simp: sorted_wrt_append)
   show ?case
   proof (cases "overlap a x")
     case True
     thus ?thesis by (auto simp: overlap_def has_overlap_def)
   next
     case a_disjoint: False
     then show ?thesis
     proof cases
       assume [simp]: "l = Leaf"
       have search_eval: "search (Node l (a, m) r) x = search r x"
         using a_disjoint overlap_def by auto
       show ?thesis
         unfolding search_eval search_r
         by (auto simp add: has_overlap_def a_disjoint)
     next
       assume "l \<noteq> Leaf"
       then show ?thesis
       proof (cases "max_hi l \<ge> low x")
         case max_hi_l_ge: True
         have "inv_max_hi l"
           using Node.prems(1) by auto
         then obtain p where p: "p \<in> set_tree l" "high p = max_hi l"
           using \<open>l \<noteq> Leaf\<close> max_hi_exists by auto
         have search_eval: "search (Node l (a, m) r) x = search l x"
           using a_disjoint \<open>l \<noteq> Leaf\<close> max_hi_l_ge by (auto simp: overlap_def)
         show ?thesis
         proof (cases "low p \<le> high x")
           case True
           have "overlap p x"
             unfolding overlap_def using True p(2) max_hi_l_ge by auto
           then show ?thesis
             unfolding search_eval search_l
             using p(1) by(auto simp: has_overlap_def overlap_def)
         next
           case False
           have "\<not>overlap x rp" if asm: "rp \<in> set_tree r" for rp
           proof -
             have "low p \<le> low rp"
               using asm p(1) Node(4) by(fastforce simp: sorted_wrt_append ivl_less)
             then show ?thesis
               using False by (auto simp: overlap_def)
           qed
           then show ?thesis
             unfolding search_eval search_l
             using a_disjoint by (auto simp: has_overlap_def overlap_def)
         qed
       next
         case False
         have search_eval: "search (Node l (a, m) r) x = search r x"
           using a_disjoint False by (auto simp: overlap_def)
         have "\<not>overlap x lp" if asm: "lp \<in> set_tree l" for lp
           using asm False Node.prems(1) max_hi_is_max
           by (fastforce simp: overlap_def)
         then show ?thesis
           unfolding search_eval search_r
           using a_disjoint by (auto simp: has_overlap_def overlap_def)
       qed
     qed
   qed
 qed
 
 definition empty :: "'a ivl_tree" where
 "empty = Leaf"
 
 
 subsection \<open>Specification\<close>
 
 locale Interval_Set = Set +
   fixes has_overlap :: "'t \<Rightarrow> 'a::linorder ivl \<Rightarrow> bool"
   assumes set_overlap: "invar s \<Longrightarrow> has_overlap s x = Interval_Tree.has_overlap (set s) x"
 
 fun invar :: "('a::{linorder,order_bot}) ivl_tree \<Rightarrow> bool" where
 "invar t = (inv_max_hi t \<and> sorted(inorder t))"
 
 interpretation S: Interval_Set
   where empty = Leaf and insert = insert and delete = delete
   and has_overlap = search and isin = isin and set = set_tree
   and invar = invar
 proof (standard, goal_cases)
   case 1
   then show ?case by auto
 next
   case 2
   then show ?case by (simp add: isin_set_inorder)
 next
   case 3
   then show ?case by(simp add: inorder_insert set_ins_list flip: set_inorder)
 next
   case 4
   then show ?case by(simp add: inorder_delete set_del_list flip: set_inorder)
 next
   case 5
   then show ?case by auto
 next
   case 6
   then show ?case by (simp add: inorder_insert inv_max_hi_insert sorted_ins_list)
 next
   case 7
   then show ?case by (simp add: inorder_delete inv_max_hi_delete sorted_del_list)
 next
   case 8
   then show ?case by (simp add: search_correct)
 qed
 
 end
diff --git a/src/HOL/Datatype_Examples/FAE_Sequence.thy b/src/HOL/Datatype_Examples/FAE_Sequence.thy
--- a/src/HOL/Datatype_Examples/FAE_Sequence.thy
+++ b/src/HOL/Datatype_Examples/FAE_Sequence.thy
@@ -1,133 +1,136 @@
 theory FAE_Sequence
   imports "HOL-Library.Confluent_Quotient"
 begin
 
 type_synonym 'a seq = "nat \<Rightarrow> 'a"
 
 abbreviation finite_range :: "('a \<Rightarrow> 'b) \<Rightarrow> bool" where "finite_range f \<equiv> finite (range f)"
 
 lemma finite_range_pair:
   assumes 1: "finite_range (\<lambda>x. fst (f x))" and 2: "finite_range (\<lambda>x. snd (f x))"
   shows "finite_range f"
 proof -
   have "range f \<subseteq> range (\<lambda>x. fst (f x)) \<times> range (\<lambda>x. snd (f x))"
     by(auto 4 3 intro: rev_image_eqI dest: sym)
   then show ?thesis by(rule finite_subset)(use assms in simp)
 qed
 
 definition seq_at :: "'a seq \<Rightarrow> 'a \<Rightarrow> nat set" where "seq_at f x = f -` {x}"
 
 typedef 'a fseq = "{f :: 'a seq. finite_range f}" morphisms ap_fseq Abs_fseq
   by(rule exI[where x="\<lambda>_. undefined"]) simp
 
 setup_lifting type_definition_fseq
 
 lift_bnf 'a fseq [wits: "\<lambda>x. (\<lambda>_ :: nat. x)"]
   subgoal by(metis finite_imageI fun.set_map mem_Collect_eq)
   subgoal by(auto intro: finite_range_pair)
   subgoal by auto
   subgoal by auto
   done
 
 lemma ap_map_fseq [simp]: "ap_fseq (map_fseq f x) = f \<circ> ap_fseq x"
   by transfer simp
 
 lift_definition fseq_eq :: "'a fseq \<Rightarrow> 'a fseq \<Rightarrow> bool" is "\<lambda>f g. finite {n. f n \<noteq> g n}" .
 
 lemma fseq_eq_unfold: "fseq_eq f g \<longleftrightarrow> finite {n. ap_fseq f n \<noteq> ap_fseq g n}"
   by transfer simp
 
 lemma reflp_fseq_eq [simp]: "reflp fseq_eq"
   by(rule reflpI)(simp add: fseq_eq_unfold)
 
 lemma symp_fseq_eq [simp]: "symp fseq_eq"
   by(rule sympI)(simp add: fseq_eq_unfold eq_commute)
 
 lemma transp_fseq_eq [simp]: "transp fseq_eq"
   apply(rule transpI)
   subgoal for f g h unfolding fseq_eq_unfold
     by(rule finite_subset[where B="{n. ap_fseq f n \<noteq> ap_fseq g n} \<union> {n. ap_fseq g n \<noteq> ap_fseq h n}"]) auto
   done
 
 lemma equivp_fseq_eq [simp]: "equivp fseq_eq"
   by(simp add: equivp_reflp_symp_transp)
 
 functor map_fseq
   by(simp_all add: fseq.map_id0 fseq.map_comp fun_eq_iff)
 
 quotient_type 'a fae_seq = "'a fseq" / fseq_eq by simp
 
 lemma map_fseq_eq: "fseq_eq f g \<Longrightarrow> fseq_eq (map_fseq h f) (map_fseq h g)"
   unfolding fseq_eq_unfold by(auto elim!: finite_subset[rotated])
 
 lemma finite_set_fseq [simp]: "finite (set_fseq x)"
   by transfer
 
 interpretation wide_intersection_fseq: wide_intersection_finite fseq_eq map_fseq set_fseq
   by unfold_locales(simp_all add: map_fseq_eq fseq.map_id[unfolded id_def] fseq.set_map cong: fseq.map_cong)
 
 lemma fseq_subdistributivity:
   assumes "A OO B \<noteq> bot"
   shows "rel_fseq A OO fseq_eq OO rel_fseq B \<le> fseq_eq OO rel_fseq (A OO B) OO fseq_eq"
 proof(rule predicate2I; elim relcomppE; transfer fixing: A B)
   fix f and g g' :: "'c seq" and h
   assume fg: "rel_fun(=) A f g" and gg': "finite {n. g n \<noteq> g' n}" and g'h: "rel_fun (=) B g' h"
     and f: "finite_range f" and g: "finite_range g" and g': "finite_range g'" and h: "finite_range h"
   from assms obtain a c b where ac: "A a c" and cb: "B c b" by(auto simp add: fun_eq_iff)
   let ?X = "{n. g n \<noteq> g' n}"
   let ?f = "\<lambda>n. if n \<in> ?X then a else f n"
   let ?h = "\<lambda>n. if n \<in> ?X then b else h n"
   have "range ?f \<subseteq> insert a (range f)" by auto
   then have "finite_range ?f" by(rule finite_subset)(simp add: f)
   moreover have "range ?h \<subseteq> insert b (range h)" by auto
   then have "finite_range ?h" by(rule finite_subset)(simp add: h)
   moreover have "{n. f n \<noteq> ?f n} \<subseteq> ?X" by auto
   then have "finite {n. f n \<noteq> ?f n}" by(rule finite_subset)(simp add: gg')
   moreover have "{n. ?h n \<noteq> h n} \<subseteq> ?X" by auto
   then have "finite {n. ?h n \<noteq> h n}" by(rule finite_subset)(simp add: gg')
   moreover have "rel_fun (=) (A OO B) ?f ?h" using fg g'h ac cb by(auto simp add: rel_fun_def)
   ultimately
   show "\<exists>ya\<in>{f. finite_range f}. finite {n. f n \<noteq> ya n} \<and> (\<exists>yb\<in>{f. finite_range f}. rel_fun (=) (A OO B) ya yb \<and> finite {n. yb n \<noteq> h n})"
     unfolding mem_Collect_eq Bex_def by blast
 qed
 
 lift_bnf 'a fae_seq
   subgoal by(rule fseq_subdistributivity)
   subgoal by(rule wide_intersection_fseq.wide_intersection)
   done
 
 lift_definition fseq_at :: "'a fseq \<Rightarrow> 'a \<Rightarrow> nat set" is seq_at .
 
 lemma fae_vimage_singleton: "finite (f -` {x}) \<longleftrightarrow> finite (g -` {x})" if "finite {n. f n \<noteq> g n}"
 proof
   assume *: "finite (g -` {x})"
   have "f -` {x} \<subseteq> g -` {x} \<union> {n. f n \<noteq> g n}" by auto
   thus "finite (f -` {x})" by(rule finite_subset)(use that * in auto)
 next
   assume *: "finite (f -` {x})"
   have "g -` {x} \<subseteq> f -` {x} \<union> {n. f n \<noteq> g n}" by auto
   thus "finite (g -` {x})" by(rule finite_subset)(use that * in auto)
 qed
 
 lift_definition set_fae_seq_alt :: "'a fae_seq \<Rightarrow> 'a set" is "\<lambda>f. {a. infinite (fseq_at f a)}"
   by(transfer)(clarsimp simp add: set_eq_iff seq_at_def fae_vimage_singleton)
 
 lemma fseq_at_infinite_Inr:
   "\<lbrakk>infinite (fseq_at f x); fseq_eq (map_fseq Inr f) g\<rbrakk> \<Longrightarrow> \<exists>x'\<in>set_fseq g. x \<in> Basic_BNFs.setr x'"
-  by transfer(auto simp add: seq_at_def vimage_def; smt (z3) finite_nat_set_iff_bounded_le mem_Collect_eq setr.intros)
+  apply transfer
+  apply (auto simp add: seq_at_def vimage_def)
+  apply (smt (verit, ccfv_SIG) finite_subset mem_Collect_eq setr.simps subsetI)
+  done
 
 lemma fseq_at_Inr_infinite:
   assumes "\<And>g. fseq_eq (map_fseq Inr f) g \<longrightarrow> (\<exists>x'\<in>set_fseq g. x \<in> Basic_BNFs.setr x')"
   shows "infinite (fseq_at f x)"
 proof
   assume fin: "finite (fseq_at f x)"
   let ?g = "map_fseq (\<lambda>y. if x = y then Inl undefined else Inr y) f"
   have "fseq_eq (map_fseq Inr f) ?g" using fin
     by transfer(simp add: seq_at_def vimage_def eq_commute)
   with assms[of "?g"] show False by(auto simp add: fseq.set_map)
 qed
 
 lemma set_fae_seq_eq_alt: "set_fae_seq f = set_fae_seq_alt f"
   by transfer(use fseq_at_Inr_infinite in \<open>force simp add: fseq_at_infinite_Inr\<close>)
 
 end
diff --git a/src/HOL/Datatype_Examples/Regex_ACIDZ.thy b/src/HOL/Datatype_Examples/Regex_ACIDZ.thy
--- a/src/HOL/Datatype_Examples/Regex_ACIDZ.thy
+++ b/src/HOL/Datatype_Examples/Regex_ACIDZ.thy
@@ -1,481 +1,481 @@
 theory Regex_ACIDZ
   imports "HOL-Library.Confluent_Quotient"
 begin
 
 datatype (discs_sels) 'a rexp = Zero | Eps | Atom 'a
   | Alt "'a rexp" "'a rexp" | Conc "'a rexp" "'a rexp" | Star "'a rexp"
 
 fun elim_zeros where
   "elim_zeros (Alt r s) =
     (let r' = elim_zeros r; s' = elim_zeros s in
      if r' = Zero then s' else if s' = Zero then r' else Alt r' s')"
 | "elim_zeros (Conc r s) = (let r' = elim_zeros r in if r' = Zero then Zero else Conc r' s)"
 | "elim_zeros r = r"
 
 fun distribute where
   "distribute t (Alt r s) = Alt (distribute t r) (distribute t s)"
 | "distribute t (Conc r s) = Conc (distribute s r) t"
 | "distribute t r = Conc r t"
 
 inductive ACIDZ (infix "~" 64) where
   a1: "Alt (Alt r s) t ~ Alt r (Alt s t)"
 | a2: "Alt r (Alt s t) ~ Alt (Alt r s) t"
 | c: "Alt r s ~ Alt s r"
 | i: "r ~ Alt r r"
 | z: "r ~ s \<Longrightarrow> r ~ elim_zeros s"
 | d: "Conc r t ~ distribute t r"
 | R: "r ~ r"
 | A: "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> Alt r s ~ Alt r' s'"
 | C: "r ~ r' \<Longrightarrow> Conc r s ~ Conc r' s"
 
 inductive_cases ACIDZ_AltE[elim]: "Alt r s ~ t"
 inductive_cases ACIDZ_ConcE[elim]: "Conc r s ~ t"
 inductive_cases ACIDZ_StarE[elim]: "Star r ~ t"
 
 declare ACIDZ.intros[intro]
 
 abbreviation ACIDZcl (infix "~~" 64) where "(~~) \<equiv> equivclp (~)"
 
 lemma map_rexp_distribute[simp]: "map_rexp f (distribute t r) = distribute (map_rexp f t) (map_rexp f r)"
   by (induct r arbitrary: t) auto
 
 lemma set_rexp_distribute[simp]: "set_rexp (distribute t r) = set_rexp r \<union> set_rexp t"
   by (induct r arbitrary: t) auto
 
 lemma Zero_eq_map_rexp_iff[simp]:
   "Zero = map_rexp f x \<longleftrightarrow> x = Zero"
   "map_rexp f x = Zero \<longleftrightarrow> x = Zero"
   by (cases x; auto)+
 
 lemma Alt_eq_map_rexp_iff:
   "Alt r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
   "map_rexp f x = Alt r s \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
   by (cases x; auto)+
 
 lemma map_rexp_elim_zeros[simp]: "map_rexp f (elim_zeros r) = elim_zeros (map_rexp f r)"
   by (induct r rule: elim_zeros.induct) (auto simp: Let_def)
 
 lemma set_rexp_elim_zeros: "set_rexp (elim_zeros r) \<subseteq> set_rexp r"
   by (induct r rule: elim_zeros.induct) (auto simp: Let_def)
 
 lemma ACIDZ_map_respects:
   fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
   assumes "r ~ s"
   shows "map_rexp f r ~ map_rexp f s"
   using assms by (induct r s rule: ACIDZ.induct) (auto simp: Let_def)
 
 lemma ACIDZcl_map_respects:
   fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
   assumes "r ~~ s"
   shows "map_rexp f r ~~ map_rexp f s"
   using assms by (induct rule: equivclp_induct) (auto intro: ACIDZ_map_respects equivclp_trans)
 
 lemma finite_set_rexp: "finite (set_rexp r)"
   by (induct r) auto
 
 lemma ACIDZ_set_rexp: "r ~ s \<Longrightarrow> set_rexp s \<subseteq> set_rexp r"
   by (induct r s rule: ACIDZ.induct) (auto dest: set_mp[OF set_rexp_elim_zeros] simp: Let_def)
 
 lemma ACIDZ_set_rexp': "(~)\<^sup>*\<^sup>* r s \<Longrightarrow> set_rexp s \<subseteq> set_rexp r"
   by (induct rule: rtranclp.induct) (auto dest: ACIDZ_set_rexp)
 
 
 lemma Conc_eq_map_rexp_iff:
   "Conc r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
   "map_rexp f x = Conc r s \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
   by (cases x; auto)+
 
 lemma Star_eq_map_rexp_iff:
   "Star r = map_rexp f x \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
   "map_rexp f x = Star r \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
   by (cases x; auto)+
 
 lemma AAA: "(~)\<^sup>*\<^sup>* r  r' \<Longrightarrow> (~)\<^sup>*\<^sup>* s s' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Alt r s) (Alt r' s')"
 proof (induct r r' rule: rtranclp.induct)
   case (rtrancl_refl r)
   then show ?case
     by (induct s s' rule: rtranclp.induct)
       (auto elim!: rtranclp.rtrancl_into_rtrancl)
 next
   case (rtrancl_into_rtrancl a b c)
   then show ?case
     by (auto elim!: rtranclp.rtrancl_into_rtrancl)
 qed
 
 lemma CCC: "(~)\<^sup>*\<^sup>* r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Conc r s) (Conc r' s)"
 proof (induct r r' rule: rtranclp.induct)
   case (rtrancl_refl r)
   then show ?case
     by simp
 next
   case (rtrancl_into_rtrancl a b c)
   then show ?case
     by (auto elim!: rtranclp.rtrancl_into_rtrancl)
 qed
 
 lemma map_rexp_ACIDZ_inv: "map_rexp f x ~ y \<Longrightarrow> \<exists>z. (~)\<^sup>*\<^sup>* x z \<and> y = map_rexp f z"
 proof (induct "map_rexp f x" y arbitrary: x rule: ACIDZ.induct)
   case (a1 r s t)
   then obtain r' s' t' where "x = Alt (Alt r' s') t'"
     "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
     by (auto simp: Alt_eq_map_rexp_iff)
   then show ?case
     by (intro exI[of _ "Alt r' (Alt s' t')"]) auto
 next
   case (a2 r s t)
   then obtain r' s' t' where "x = Alt r' (Alt s' t')"
     "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
     by (auto simp: Alt_eq_map_rexp_iff)
   then show ?case
     by (intro exI[of _ "Alt (Alt r' s') t'"]) auto
 next
   case (c r s)
   then obtain r' s' where "x = Alt r' s'"
     "map_rexp f r' = r" "map_rexp f s' = s"
     by (auto simp: Alt_eq_map_rexp_iff)
   then show ?case
     by (intro exI[of _ "Alt s' r'"]) auto
 next
   case (i r)
   then show ?case
     by (intro exI[of _ "Alt r r"]) auto
 next
   case (z r)
   then show ?case
     by (metis ACIDZ.z R map_rexp_elim_zeros rtranclp.simps)
 next
   case (d r s)
   then obtain r' s' where "x = Conc r' s'"
     "map_rexp f r' = r" "map_rexp f s' = s"
     by (auto simp: Conc_eq_map_rexp_iff)
   then show ?case
     by (intro exI[of _ "distribute s' r'"]) auto
 next
   case (R r)
   then show ?case by (auto intro: exI[of _ r])
 next
   case (A r rr s ss)
   then obtain r' s' where "x = Alt r' s'"
     "map_rexp f r' = r" "map_rexp f s' = s"
     by (auto simp: Alt_eq_map_rexp_iff)
   moreover from A(2)[OF this(2)[symmetric]] A(4)[OF this(3)[symmetric]] obtain rr' ss' where
     "(~)\<^sup>*\<^sup>* r' rr'" "rr = map_rexp f rr'" "(~)\<^sup>*\<^sup>* s' ss'" "ss = map_rexp f ss'"
     by blast
   ultimately show ?case using A(1,3)
     by (intro exI[of _ "Alt rr' ss'"]) (auto intro!: AAA)
 next
   case (C r rr s)
   then obtain r' s' where "x = Conc r' s'"
     "map_rexp f r' = r" "map_rexp f s' = s"
     by (auto simp: Conc_eq_map_rexp_iff)
   moreover from C(2)[OF this(2)[symmetric]] obtain rr' where
     "(~)\<^sup>*\<^sup>* r' rr'" "rr = map_rexp f rr'"
     by blast
   ultimately show ?case using C(1,3)
     by (intro exI[of _ "Conc rr' s'"]) (auto intro!: CCC)
 qed
 
 lemma reflclp_ACIDZ: "(~)\<^sup>=\<^sup>= = (~)"
   unfolding fun_eq_iff
   by auto
 
 lemma elim_zeros_distribute_Zero: "elim_zeros r = Zero \<Longrightarrow> elim_zeros (distribute t r) = Zero"
   by (induct r arbitrary: t) (auto simp: Let_def split: if_splits)
 
 lemma elim_zeros_ACIDZ_Zero: "r ~ s \<Longrightarrow> elim_zeros r = Zero \<Longrightarrow> elim_zeros s = Zero"
   by (induct r s rule: ACIDZ.induct) (auto simp: Let_def elim_zeros_distribute_Zero split: if_splits)
 
 lemma AZZ[simp]: "Alt Zero Zero ~ Zero"
   by (metis elim_zeros.simps(3) elim_zeros_ACIDZ_Zero i z)
 
 lemma elim_zeros_idem[simp]: "elim_zeros (elim_zeros r) = elim_zeros r"
   by (induct r rule: elim_zeros.induct) (auto simp: Let_def)
 
 lemma elim_zeros_distribute_idem: "elim_zeros (distribute s (elim_zeros r)) = elim_zeros (distribute s r)"
   by (induct r arbitrary: s rule: elim_zeros.induct) (auto simp: Let_def)
 
 lemma zz: "r ~ s \<Longrightarrow> t = elim_zeros s \<Longrightarrow> r ~ t"
   by (metis z)
 
 lemma elim_zeros_ACIDZ1: "r ~ s \<Longrightarrow> elim_zeros r ~ elim_zeros s"
 proof (induct r s rule: ACIDZ.induct)
   case (c r s)
   then show ?case by (auto simp: Let_def)
 next
   case (d r t)
   then show ?case
-    by (smt (z3) ACIDZ.d R distribute.simps(3) elim_zeros.simps(2) elim_zeros.simps(3) elim_zeros_distribute_idem z)
+    by (smt (verit, ccfv_SIG) ACIDZ.d R elim_zeros.simps(2) elim_zeros_distribute_Zero elim_zeros_distribute_idem z)
 next
   case (A r r' s s')
   then show ?case
     by (auto 0 2 simp: Let_def dest: elim_zeros_ACIDZ_Zero elim: zz[OF ACIDZ.A])
 next
   case (C r r' s)
   then show ?case
-    by (smt (z3) ACIDZ.C elim_zeros.simps(2,3) z elim_zeros_ACIDZ_Zero)
+    by (smt (verit, best) ACIDZ.C R elim_zeros.simps(2) elim_zeros_ACIDZ_Zero z)
 qed (auto simp: Let_def)
 
 lemma AA': "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> t = elim_zeros (Alt r' s') \<Longrightarrow> Alt r s ~ t"
   by (auto simp del: elim_zeros.simps)
 
 lemma distribute_ACIDZ1: "r ~ r' \<Longrightarrow> distribute s r ~ elim_zeros (distribute s r')"
 proof (induct r r' arbitrary: s rule: ACIDZ.induct)
   case (A r r' s s' u)
   from A(2,4)[of u] show ?case
     by (auto simp: Let_def elim: zz[OF ACIDZ.A])
 next
   case (C r r' s)
   then show ?case
     by (smt (verit, best) ACIDZ.C distribute.simps(2,3) elim_zeros.simps(2,3) z)
 qed (auto simp del: elim_zeros.simps simp: elim_zeros_distribute_idem)
 
 lemma elim_zeros_ACIDZ: "r ~ s \<Longrightarrow> (~)\<^sup>*\<^sup>* (elim_zeros r) (elim_zeros s)"
   using elim_zeros_ACIDZ1 by blast
 
 lemma elim_zeros_ACIDZ_rtranclp: "(~)\<^sup>*\<^sup>* r s \<Longrightarrow> (~)\<^sup>*\<^sup>* (elim_zeros r) (elim_zeros s)"
   by (induct rule: rtranclp_induct) (auto elim!: rtranclp_trans elim_zeros_ACIDZ)
 
 lemma distribute_ACIDZ: "(~) r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* (distribute s r) (elim_zeros (distribute s r'))"
   by (metis distribute_ACIDZ1 rtranclp.simps)
 
 lemma ACIDZ_elim_zeros: "(~) r s \<Longrightarrow> elim_zeros r = Zero \<Longrightarrow> elim_zeros s = Zero"
   by (meson elim_zeros_ACIDZ1 elim_zeros_ACIDZ_Zero)
 
 lemma ACIDZ_elim_zeros_rtranclp:
   "(~)\<^sup>*\<^sup>* r s \<Longrightarrow> elim_zeros r = Zero \<Longrightarrow> elim_zeros s = Zero"
   by (induct rule: rtranclp_induct) (auto elim: ACIDZ_elim_zeros)
 
 lemma Alt_elim_zeros[simp]:
   "Alt (elim_zeros r) s ~ elim_zeros (Alt r s)"
   "Alt r (elim_zeros s) ~ elim_zeros (Alt r s)"
   by (smt (verit, ccfv_threshold) ACIDZ.simps elim_zeros.simps(1) elim_zeros_idem)+
 
 lemma strong_confluentp_ACIDZ: "strong_confluentp (~)"
 proof (rule strong_confluentpI, unfold reflclp_ACIDZ)
   fix x y z :: "'a rexp"
   assume "x ~ y" "x ~ z"
   then show "\<exists>u. (~)\<^sup>*\<^sup>* y u \<and> z ~ u"
   proof (induct x y arbitrary: z rule: ACIDZ.induct)
     case (a1 r s t)
     then show ?case
       by (auto intro: AAA converse_rtranclp_into_rtranclp)
   next
     case (a2 r s t)
     then show ?case
       by (auto intro: AAA converse_rtranclp_into_rtranclp)
   next
     case (c r s)
     then show ?case
       by (cases rule: ACIDZ.cases)
         (auto 0 4 intro: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ R], rotated]
           converse_rtranclp_into_rtranclp[where r="(~)", OF ACIDZ.c])
   next
     case (i r)
     then show ?case
       by (auto intro: AAA)
   next
     case (z r s)
     then show ?case
       by (meson ACIDZ.z elim_zeros_ACIDZ_rtranclp)
   next
     case (d r s t)
     then show ?case
       by (induct "Conc r s" t rule: ACIDZ.induct)
         (force intro: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ z], rotated]
           exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ z[OF elim_zeros_ACIDZ1]], rotated]
           distribute_ACIDZ1 elim!: rtranclp_trans)+
   next
     case (R r)
     then show ?case
       by auto
   next
     note A1 = ACIDZ.A[OF _ R]
     note A2 = ACIDZ.A[OF R]
     case (A r r' s s')
     from A(5,1-4) show ?case
     proof (induct "Alt r s" z rule: ACIDZ.induct)
       case inner: (a1 r'' s'')
       from A(1,3) show ?case
         unfolding inner.hyps[symmetric]
       proof (induct "Alt r'' s''" r' rule: ACIDZ.induct[consumes 1, case_names Xa1 Xa2 Xc Xi Xz Xd XR XA XC])
         case Xa1
         with A(3) show ?case
           by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis A1 a1 a2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
       next
         case Xa2
         then show ?case
           by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
             (metis a1 A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
       next
         case Xc
         then show ?case
           by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
             (metis a1 c A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
       next
         case Xi
         then show ?case
           apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACIDZ.A[OF i ACIDZ.A[OF i]]], rotated])
           apply (rule converse_rtranclp_into_rtranclp, rule a1)
           apply (rule converse_rtranclp_into_rtranclp, rule a1)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
           apply (rule converse_rtranclp_into_rtranclp, rule a2)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
           apply blast
           done
       next
         case Xz
         with A show ?case
           by (auto elim!: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ z], rotated]
             converse_rtranclp_into_rtranclp[rotated, OF elim_zeros_ACIDZ_rtranclp]
             simp del: elim_zeros.simps)
       qed auto
     next
       case inner: (a2 s'' t'')
       from A(3,1) show ?case
         unfolding inner.hyps[symmetric]
       proof (induct "Alt s'' t''" s' rule: ACIDZ.induct[consumes 1, case_names Xa1 Xa2 Xc Xi Xz Xd XR XA XC])
         case Xa1
         with A(3) show ?case
           by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
             (metis a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
       next
         case Xa2
         then show ?case
           by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
             (metis a1 a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
       next
         case Xc
         then show ?case
           by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
             (metis a2 c A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
       next
         case Xi
         then show ?case
           apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACIDZ.A[OF ACIDZ.A[OF _ i] i]], rotated])
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A2, rule a1)
           apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
           apply (rule converse_rtranclp_into_rtranclp, rule a2)
           apply blast
           done
       next
         case Xz
         then show ?case
           by (auto elim!: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ z], rotated]
             converse_rtranclp_into_rtranclp[rotated, OF elim_zeros_ACIDZ_rtranclp]
             simp del: elim_zeros.simps)
       qed auto
     next
       case (z rs) with A show ?case
         by (auto elim!: rtranclp_trans
           intro!: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ elim_zeros_ACIDZ1], rotated])
     qed (auto 5 0 intro: AAA)
   next
     case (C r r' s s')
     from C(3,1-2) show ?case
       by (induct "Conc r s" s' rule: ACIDZ.induct)
         (auto intro: CCC elim!: rtranclp_trans
           exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ elim_zeros_ACIDZ1], rotated]
           exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ distribute_ACIDZ1], rotated])
   qed
 qed
 
 lemma confluent_quotient_ACIDZ:
   "confluent_quotient (~) (~~) (~~) (~~) (~~) (~~)
      (map_rexp fst) (map_rexp snd) (map_rexp fst) (map_rexp snd)
      rel_rexp rel_rexp rel_rexp set_rexp set_rexp"
   by unfold_locales
     (auto 4 4 dest: ACIDZ_set_rexp' simp: rexp.in_rel rexp.rel_compp dest: map_rexp_ACIDZ_inv intro: rtranclp_into_equivclp
       intro: equivpI reflpI sympI transpI ACIDZcl_map_respects
       strong_confluentp_imp_confluentp[OF strong_confluentp_ACIDZ])
 
 lemma wide_intersection_finite_ACIDZ: "wide_intersection_finite (~~) map_rexp set_rexp"
   by unfold_locales
     (auto intro: ACIDZcl_map_respects rexp.map_cong simp: rexp.map_id rexp.set_map finite_set_rexp)
 
 inductive ACIDZEQ (infix "\<approx>" 64) where
   a: "Alt (Alt r s) t \<approx> Alt r (Alt s t)"
 | c: "Alt r s \<approx> Alt s r"
 | i: "Alt r r \<approx> r"
 | cz: "Conc Zero r \<approx> Zero"
 | az: "Alt Zero r \<approx> r"
 | d: "Conc (Alt r s) t \<approx> Alt (Conc r t) (Conc s t)"
 | A: "r \<approx> r' \<Longrightarrow> s \<approx> s' \<Longrightarrow> Alt r s \<approx> Alt r' s'"
 | C: "r \<approx> r' \<Longrightarrow> Conc r s \<approx> Conc r' s"
 | r: "r \<approx> r"
 | s: "r \<approx> s \<Longrightarrow> s \<approx> r"
 | t: "r \<approx> s \<Longrightarrow> s \<approx> t \<Longrightarrow> r \<approx> t"
 
 context begin
 
 private lemma AA: "r ~~ r' \<Longrightarrow> s ~~ s' \<Longrightarrow> Alt r s ~~ Alt r' s'"
 proof (induct rule: equivclp_induct)
   case base
   then show ?case
     by (induct rule: equivclp_induct) (auto elim!: equivclp_trans)
 next
   case (step s t)
   then show ?case
     by (auto elim!: equivclp_trans)
 qed
 
 private lemma CC: "r ~~ r' \<Longrightarrow> Conc r s ~~ Conc r' s"
 proof (induct rule: equivclp_induct)
   case base
   then show ?case
     by simp
 next
   case (step s t)
   then show ?case
     by (auto elim!: equivclp_trans)
 qed
 
 private lemma CZ: "Conc Zero r ~~ Zero"
-  by (smt (z3) R elim_zeros.simps(2) elim_zeros.simps(3) r_into_equivclp z)
+  by (metis R distribute.simps(3) elim_zeros.simps(3) elim_zeros_distribute_Zero r_into_equivclp z)
 
 private lemma AZ: "Alt Zero r ~~ r"
   by (smt (verit, ccfv_threshold) converse_r_into_equivclp converse_rtranclp_into_rtranclp
     elim_zeros.simps(1) elim_zeros.simps(3) equivclp_def symclpI1 z R)
 
 private lemma D: "Conc (Alt r s) t ~~ Alt (Conc r t) (Conc s t)"
   by (smt (verit, ccfv_threshold) AA ACIDZ.d converse_r_into_equivclp distribute.simps(1)
     equivclp_sym rtranclp.simps rtranclp_equivclp)
 
 lemma ACIDZEQ_le_ACIDZcl: "r \<approx> s \<Longrightarrow> r ~~ s"
   by (induct r s rule: ACIDZEQ.induct) (auto intro: AA CC AZ CZ D equivclp_sym equivclp_trans)
 
 end
 
 lemma ACIDZEQ_z[simp]: "r \<approx> elim_zeros r"
   by (induct r rule: elim_zeros.induct) (auto 0 3 intro: ACIDZEQ.intros simp: Let_def)
 
 lemma ACIDZEQ_d[simp]: "Conc r s \<approx> distribute s r"
   by (induct s r rule: distribute.induct) (auto 0 3 intro: ACIDZEQ.intros)
 
 lemma ACIDZ_le_ACIDZEQ: "r ~ s \<Longrightarrow> r \<approx> s"
   by (induct r s rule: ACIDZ.induct) (auto 0 2 intro: ACIDZEQ.intros simp: Let_def)
 
 lemma ACIDZcl_le_ACIDZEQ: "r ~~ s \<Longrightarrow> r \<approx> s"
   by (induct rule: equivclp_induct) (auto 0 3 intro: ACIDZEQ.intros ACIDZ_le_ACIDZEQ)
 
 lemma ACIDZEQ_alt: "(\<approx>) = (~~)"
   by (simp add: ACIDZEQ_le_ACIDZcl ACIDZcl_le_ACIDZEQ antisym predicate2I)
 
 quotient_type 'a rexp_ACIDZ = "'a rexp" / "(\<approx>)"
   unfolding ACIDZEQ_alt by (auto intro!: equivpI reflpI sympI transpI)
 
 lift_bnf 'a rexp_ACIDZ
   unfolding ACIDZEQ_alt
   subgoal for A Q by (rule confluent_quotient.subdistributivity[OF confluent_quotient_ACIDZ])
   subgoal for Ss by (elim wide_intersection_finite.wide_intersection[OF wide_intersection_finite_ACIDZ])
   done
 
 datatype ldl = Prop string | And ldl ldl | Not ldl | Match "ldl rexp_ACIDZ"
 
 end
diff --git a/src/HOL/Hoare/Hoare_Logic_Abort.thy b/src/HOL/Hoare/Hoare_Logic_Abort.thy
--- a/src/HOL/Hoare/Hoare_Logic_Abort.thy
+++ b/src/HOL/Hoare/Hoare_Logic_Abort.thy
@@ -1,236 +1,236 @@
 (*  Title:      HOL/Hoare/Hoare_Logic_Abort.thy
     Author:     Leonor Prensa Nieto & Tobias Nipkow
     Copyright   2003 TUM
     Author:     Walter Guttmann (extension to total-correctness proofs)
 *)
 
 section \<open>Hoare Logic with an Abort statement for modelling run time errors\<close>
 
 theory Hoare_Logic_Abort
   imports Hoare_Syntax Hoare_Tac
 begin
 
 type_synonym 'a bexp = "'a set"
 type_synonym 'a assn = "'a set"
 type_synonym 'a var = "'a \<Rightarrow> nat"
 
 datatype 'a com =
   Basic "'a \<Rightarrow> 'a"
 | Abort
 | Seq "'a com" "'a com"
 | Cond "'a bexp" "'a com" "'a com"
 | While "'a bexp" "'a assn" "'a var" "'a com"
 
 abbreviation annskip ("SKIP") where "SKIP == Basic id"
 
 type_synonym 'a sem = "'a option => 'a option => bool"
 
 inductive Sem :: "'a com \<Rightarrow> 'a sem"
 where
   "Sem (Basic f) None None"
 | "Sem (Basic f) (Some s) (Some (f s))"
 | "Sem Abort s None"
 | "Sem c1 s s'' \<Longrightarrow> Sem c2 s'' s' \<Longrightarrow> Sem (Seq c1 c2) s s'"
 | "Sem (Cond b c1 c2) None None"
 | "s \<in> b \<Longrightarrow> Sem c1 (Some s) s' \<Longrightarrow> Sem (Cond b c1 c2) (Some s) s'"
 | "s \<notin> b \<Longrightarrow> Sem c2 (Some s) s' \<Longrightarrow> Sem (Cond b c1 c2) (Some s) s'"
 | "Sem (While b x y c) None None"
 | "s \<notin> b \<Longrightarrow> Sem (While b x y c) (Some s) (Some s)"
 | "s \<in> b \<Longrightarrow> Sem c (Some s) s'' \<Longrightarrow> Sem (While b x y c) s'' s' \<Longrightarrow>
    Sem (While b x y c) (Some s) s'"
 
 inductive_cases [elim!]:
   "Sem (Basic f) s s'" "Sem (Seq c1 c2) s s'"
   "Sem (Cond b c1 c2) s s'"
 
 lemma Sem_deterministic:
   assumes "Sem c s s1"
       and "Sem c s s2"
     shows "s1 = s2"
 proof -
   have "Sem c s s1 \<Longrightarrow> (\<forall>s2. Sem c s s2 \<longrightarrow> s1 = s2)"
     by (induct rule: Sem.induct) (subst Sem.simps, blast)+
   thus ?thesis
     using assms by simp
 qed
 
 definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
   where "Valid p c q \<equiv> \<forall>s s'. Sem c s s' \<longrightarrow> s \<in> Some ` p \<longrightarrow> s' \<in> Some ` q"
 
 definition ValidTC :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
   where "ValidTC p c q \<equiv> \<forall>s . s \<in> p \<longrightarrow> (\<exists>t . Sem c (Some s) (Some t) \<and> t \<in> q)"
 
 lemma tc_implies_pc:
   "ValidTC p c q \<Longrightarrow> Valid p c q"
-  by (smt Sem_deterministic ValidTC_def Valid_def image_iff)
+  by (smt (verit) Sem_deterministic ValidTC_def Valid_def image_iff)
 
 lemma tc_extract_function:
   "ValidTC p c q \<Longrightarrow> \<exists>f . \<forall>s . s \<in> p \<longrightarrow> f s \<in> q"
   by (meson ValidTC_def)
 
 text \<open>The proof rules for partial correctness\<close>
 
 lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
 by (auto simp:Valid_def)
 
 lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
 by (auto simp:Valid_def)
 
 lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (Seq c1 c2) R"
 by (auto simp:Valid_def)
 
 lemma CondRule:
  "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
   \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
 by (fastforce simp:Valid_def image_def)
 
 lemma While_aux:
   assumes "Sem (While b i v c) s s'"
   shows "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> Some ` (I \<inter> b) \<longrightarrow> s' \<in> Some ` I \<Longrightarrow>
     s \<in> Some ` I \<Longrightarrow> s' \<in> Some ` (I \<inter> -b)"
   using assms
   by (induct "While b i v c" s s') auto
 
 lemma WhileRule:
  "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i v c) q"
 apply (clarsimp simp:Valid_def)
 apply(drule While_aux)
   apply assumption
  apply blast
 apply blast
 done
 
 lemma AbortRule: "p \<subseteq> {s. False} \<Longrightarrow> Valid p Abort q"
 by(auto simp:Valid_def)
 
 text \<open>The proof rules for total correctness\<close>
 
 lemma SkipRuleTC:
   assumes "p \<subseteq> q"
     shows "ValidTC p (Basic id) q"
   by (metis Sem.intros(2) ValidTC_def assms id_def subsetD)
 
 lemma BasicRuleTC:
   assumes "p \<subseteq> {s. f s \<in> q}"
     shows "ValidTC p (Basic f) q"
   by (metis Ball_Collect Sem.intros(2) ValidTC_def assms)
 
 lemma SeqRuleTC:
   assumes "ValidTC p c1 q"
       and "ValidTC q c2 r"
     shows "ValidTC p (Seq c1 c2) r"
   by (meson assms Sem.intros(4) ValidTC_def)
 
 lemma CondRuleTC:
  assumes "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}"
      and "ValidTC w c1 q"
      and "ValidTC w' c2 q"
    shows "ValidTC p (Cond b c1 c2) q"
 proof (unfold ValidTC_def, rule allI)
   fix s
   show "s \<in> p \<longrightarrow> (\<exists>t . Sem (Cond b c1 c2) (Some s) (Some t) \<and> t \<in> q)"
     apply (cases "s \<in> b")
     apply (metis (mono_tags, lifting) Ball_Collect Sem.intros(6) ValidTC_def assms(1,2))
     by (metis (mono_tags, lifting) Ball_Collect Sem.intros(7) ValidTC_def assms(1,3))
 qed
 
 lemma WhileRuleTC:
   assumes "p \<subseteq> i"
       and "\<And>n::nat . ValidTC (i \<inter> b \<inter> {s . v s = n}) c (i \<inter> {s . v s < n})"
       and "i \<inter> uminus b \<subseteq> q"
     shows "ValidTC p (While b i v c) q"
 proof -
   {
     fix s n
     have "s \<in> i \<and> v s = n \<longrightarrow> (\<exists>t . Sem (While b i v c) (Some s) (Some t) \<and> t \<in> q)"
     proof (induction "n" arbitrary: s rule: less_induct)
       fix n :: nat
       fix s :: 'a
       assume 1: "\<And>(m::nat) s::'a . m < n \<Longrightarrow> s \<in> i \<and> v s = m \<longrightarrow> (\<exists>t . Sem (While b i v c) (Some s) (Some t) \<and> t \<in> q)"
       show "s \<in> i \<and> v s = n \<longrightarrow> (\<exists>t . Sem (While b i v c) (Some s) (Some t) \<and> t \<in> q)"
       proof (rule impI, cases "s \<in> b")
         assume 2: "s \<in> b" and "s \<in> i \<and> v s = n"
         hence "s \<in> i \<inter> b \<inter> {s . v s = n}"
           using assms(1) by auto
         hence "\<exists>t . Sem c (Some s) (Some t) \<and> t \<in> i \<inter> {s . v s < n}"
           by (metis assms(2) ValidTC_def)
         from this obtain t where 3: "Sem c (Some s) (Some t) \<and> t \<in> i \<inter> {s . v s < n}"
           by auto
         hence "\<exists>u . Sem (While b i v c) (Some t) (Some u) \<and> u \<in> q"
           using 1 by auto
         thus "\<exists>t . Sem (While b i v c) (Some s) (Some t) \<and> t \<in> q"
           using 2 3 Sem.intros(10) by force
       next
         assume "s \<notin> b" and "s \<in> i \<and> v s = n"
         thus "\<exists>t . Sem (While b i v c) (Some s) (Some t) \<and> t \<in> q"
           using Sem.intros(9) assms(3) by fastforce
       qed
     qed
   }
   thus ?thesis
     using assms(1) ValidTC_def by force
 qed
 
 
 subsection \<open>Concrete syntax\<close>
 
 setup \<open>
   Hoare_Syntax.setup
    {Basic = \<^const_syntax>\<open>Basic\<close>,
     Skip = \<^const_syntax>\<open>annskip\<close>,
     Seq = \<^const_syntax>\<open>Seq\<close>,
     Cond = \<^const_syntax>\<open>Cond\<close>,
     While = \<^const_syntax>\<open>While\<close>,
     Valid = \<^const_syntax>\<open>Valid\<close>,
     ValidTC = \<^const_syntax>\<open>ValidTC\<close>}
 \<close>
 
 \<comment> \<open>Special syntax for guarded statements and guarded array updates:\<close>
 syntax
   "_guarded_com" :: "bool \<Rightarrow> 'a com \<Rightarrow> 'a com"  ("(2_ \<rightarrow>/ _)" 71)
   "_array_update" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a com"  ("(2_[_] :=/ _)" [70, 65] 61)
 translations
   "P \<rightarrow> c" \<rightleftharpoons> "IF P THEN c ELSE CONST Abort FI"
   "a[i] := v" \<rightharpoonup> "(i < CONST length a) \<rightarrow> (a := CONST list_update a i v)"
   \<comment> \<open>reverse translation not possible because of duplicate \<open>a\<close>\<close>
 
 text \<open>
   Note: there is no special syntax for guarded array access. Thus
   you must write \<open>j < length a \<rightarrow> a[i] := a!j\<close>.
 \<close>
 
 
 subsection \<open>Proof methods: VCG\<close>
 
 declare BasicRule [Hoare_Tac.BasicRule]
   and SkipRule [Hoare_Tac.SkipRule]
   and AbortRule [Hoare_Tac.AbortRule]
   and SeqRule [Hoare_Tac.SeqRule]
   and CondRule [Hoare_Tac.CondRule]
   and WhileRule [Hoare_Tac.WhileRule]
 
 declare BasicRuleTC [Hoare_Tac.BasicRuleTC]
   and SkipRuleTC [Hoare_Tac.SkipRuleTC]
   and SeqRuleTC [Hoare_Tac.SeqRuleTC]
   and CondRuleTC [Hoare_Tac.CondRuleTC]
   and WhileRuleTC [Hoare_Tac.WhileRuleTC]
 
 method_setup vcg = \<open>
   Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare_Tac.hoare_tac ctxt (K all_tac)))\<close>
   "verification condition generator"
 
 method_setup vcg_simp = \<open>
   Scan.succeed (fn ctxt =>
     SIMPLE_METHOD' (Hoare_Tac.hoare_tac ctxt (asm_full_simp_tac ctxt)))\<close>
   "verification condition generator plus simplification"
 
 method_setup vcg_tc = \<open>
   Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare_Tac.hoare_tc_tac ctxt (K all_tac)))\<close>
   "verification condition generator"
 
 method_setup vcg_tc_simp = \<open>
   Scan.succeed (fn ctxt =>
     SIMPLE_METHOD' (Hoare_Tac.hoare_tc_tac ctxt (asm_full_simp_tac ctxt)))\<close>
   "verification condition generator plus simplification"
 
 end
diff --git a/src/HOL/Homology/Simplices.thy b/src/HOL/Homology/Simplices.thy
--- a/src/HOL/Homology/Simplices.thy
+++ b/src/HOL/Homology/Simplices.thy
@@ -1,3270 +1,3271 @@
 section\<open>Homology, I: Simplices\<close>
 
 theory "Simplices"
   imports
     "HOL-Analysis.Function_Metric"
     "HOL-Analysis.Abstract_Euclidean_Space"
     "HOL-Algebra.Free_Abelian_Groups"
 begin
 
 subsection\<open>Standard simplices, all of which are topological subspaces of @{text"R^n"}.      \<close>
 
 type_synonym 'a chain = "((nat \<Rightarrow> real) \<Rightarrow> 'a) \<Rightarrow>\<^sub>0 int"
 
 definition standard_simplex :: "nat \<Rightarrow> (nat \<Rightarrow> real) set" where
   "standard_simplex p \<equiv>
     {x. (\<forall>i. 0 \<le> x i \<and> x i \<le> 1) \<and> (\<forall>i>p. x i = 0) \<and> (\<Sum>i\<le>p. x i) = 1}"
 
 lemma topspace_standard_simplex:
   "topspace(subtopology (powertop_real UNIV) (standard_simplex p))
     = standard_simplex p"
   by simp
 
 lemma basis_in_standard_simplex [simp]:
    "(\<lambda>j. if j = i then 1 else 0) \<in> standard_simplex p \<longleftrightarrow> i \<le> p"
   by (auto simp: standard_simplex_def)
 
 lemma nonempty_standard_simplex: "standard_simplex p \<noteq> {}"
   using basis_in_standard_simplex by blast
 
 lemma standard_simplex_0: "standard_simplex 0 = {(\<lambda>j. if j = 0 then 1 else 0)}"
   by (auto simp: standard_simplex_def)
 
 lemma standard_simplex_mono:
   assumes "p \<le> q"
   shows "standard_simplex p \<subseteq> standard_simplex q"
   using assms
 proof (clarsimp simp: standard_simplex_def)
   fix x :: "nat \<Rightarrow> real"
   assume "\<forall>i. 0 \<le> x i \<and> x i \<le> 1" and "\<forall>i>p. x i = 0" and "sum x {..p} = 1"
   then show "sum x {..q} = 1"
     using sum.mono_neutral_left [of "{..q}" "{..p}" x] assms by auto
 qed
 
 lemma closedin_standard_simplex:
    "closedin (powertop_real UNIV) (standard_simplex p)"
     (is "closedin ?X ?S")
 proof -
   have eq: "standard_simplex p =
               (\<Inter>i. {x. x \<in> topspace ?X \<and> x i \<in> {0..1}}) \<inter>
               (\<Inter>i \<in> {p<..}. {x \<in> topspace ?X. x i \<in> {0}}) \<inter>
               {x \<in> topspace ?X. (\<Sum>i\<le>p. x i) \<in> {1}}"
     by (auto simp: standard_simplex_def topspace_product_topology)
   show ?thesis
     unfolding eq
     by (rule closedin_Int closedin_Inter continuous_map_sum
              continuous_map_product_projection closedin_continuous_map_preimage | force | clarify)+
 qed
 
 lemma standard_simplex_01: "standard_simplex p \<subseteq> UNIV \<rightarrow>\<^sub>E {0..1}"
   using standard_simplex_def by auto
 
 lemma compactin_standard_simplex:
    "compactin (powertop_real UNIV) (standard_simplex p)"
 proof (rule closed_compactin)
   show "compactin (powertop_real UNIV) (UNIV \<rightarrow>\<^sub>E {0..1})"
     by (simp add: compactin_PiE)
   show "standard_simplex p \<subseteq> UNIV \<rightarrow>\<^sub>E {0..1}"
     by (simp add: standard_simplex_01)
   show "closedin (powertop_real UNIV) (standard_simplex p)"
     by (simp add: closedin_standard_simplex)
 qed
 
 lemma convex_standard_simplex:
    "\<lbrakk>x \<in> standard_simplex p; y \<in> standard_simplex p;
      0 \<le> u; u \<le> 1\<rbrakk>
     \<Longrightarrow> (\<lambda>i. (1 - u) * x i + u * y i) \<in> standard_simplex p"
   by (simp add: standard_simplex_def sum.distrib convex_bound_le flip: sum_distrib_left)
 
 lemma path_connectedin_standard_simplex:
    "path_connectedin (powertop_real UNIV) (standard_simplex p)"
 proof -
   define g where "g \<equiv> \<lambda>x y::nat\<Rightarrow>real. \<lambda>u i. (1 - u) * x i + u * y i"
   have "continuous_map
                 (subtopology euclideanreal {0..1}) (powertop_real UNIV)
                 (g x y)"
     if "x \<in> standard_simplex p" "y \<in> standard_simplex p" for x y
     unfolding g_def continuous_map_componentwise
     by (force intro: continuous_intros)
   moreover
   have "g x y ` {0..1} \<subseteq> standard_simplex p" "g x y 0 = x" "g x y 1 = y"
     if "x \<in> standard_simplex p" "y \<in> standard_simplex p" for x y
     using that by (auto simp: convex_standard_simplex g_def)
   ultimately
   show ?thesis
     unfolding path_connectedin_def path_connected_space_def pathin_def
     by (metis continuous_map_in_subtopology euclidean_product_topology top_greatest topspace_euclidean topspace_euclidean_subtopology)
 qed
 
 lemma connectedin_standard_simplex:
    "connectedin (powertop_real UNIV) (standard_simplex p)"
   by (simp add: path_connectedin_imp_connectedin path_connectedin_standard_simplex)
 
 subsection\<open>Face map\<close>
 
 definition simplical_face :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a::comm_monoid_add" where
    "simplical_face k x \<equiv> \<lambda>i. if i < k then x i else if i = k then 0 else x(i -1)"
 
 lemma simplical_face_in_standard_simplex:
   assumes "1 \<le> p" "k \<le> p" "x \<in> standard_simplex (p - Suc 0)"
   shows "(simplical_face k x) \<in> standard_simplex p"
 proof -
   have x01: "\<And>i. 0 \<le> x i \<and> x i \<le> 1" and sumx: "sum x {..p - Suc 0} = 1"
     using assms by (auto simp: standard_simplex_def simplical_face_def)
   have gg: "\<And>g. sum g {..p} = sum g {..<k} + sum g {k..p}"
     using \<open>k \<le> p\<close> sum.union_disjoint [of "{..<k}" "{k..p}"]
     by (force simp: ivl_disj_un ivl_disj_int)
   have eq: "(\<Sum>i\<le>p. if i < k then x i else if i = k then 0 else x (i -1))
          = (\<Sum>i < k. x i) + (\<Sum>i \<in> {k..p}. if i = k then 0 else x (i -1))"
     by (simp add: gg)
   consider "k \<le> p - Suc 0" | "k = p"
     using \<open>k \<le> p\<close> by linarith
   then have "(\<Sum>i\<le>p. if i < k then x i else if i = k then 0 else x (i -1)) = 1"
   proof cases
     case 1
     have [simp]: "Suc (p - Suc 0) = p"
       using \<open>1 \<le> p\<close> by auto
     have "(\<Sum>i = k..p. if i = k then 0 else x (i -1)) = (\<Sum>i = k+1..p. if i = k then 0 else x (i -1))"
       by (rule sum.mono_neutral_right) auto
     also have "\<dots> = (\<Sum>i = k+1..p. x (i -1))"
       by simp
     also have "\<dots> = (\<Sum>i = k..p-1. x i)"
       using sum.atLeastAtMost_reindex [of Suc k "p-1" "\<lambda>i. x (i - Suc 0)"] 1 by simp
     finally have eq2: "(\<Sum>i = k..p. if i = k then 0 else x (i -1)) = (\<Sum>i = k..p-1. x i)" .
     with 1 show ?thesis 
       by (metis (no_types, lifting) One_nat_def eq finite_atLeastAtMost finite_lessThan ivl_disj_int(4) ivl_disj_un(10) sum.union_disjoint sumx)
   next
     case 2
     have [simp]: "({..p} \<inter> {x. x < p}) = {..p - Suc 0}"
       using assms by auto
     have "(\<Sum>i\<le>p. if i < p then x i else if i = k then 0 else x (i -1)) = (\<Sum>i\<le>p. if i < p then x i else 0)"
       by (rule sum.cong) (auto simp: 2)
     also have "\<dots> = sum x {..p-1}"
       by (simp add: sum.If_cases)
     also have "\<dots> = 1"
       by (simp add: sumx)
     finally show ?thesis
       using 2 by simp
   qed
   then show ?thesis
     using assms by (auto simp: standard_simplex_def simplical_face_def)
 qed
 
 subsection\<open>Singular simplices, forcing canonicity outside the intended domain\<close>
 
 definition singular_simplex :: "nat \<Rightarrow> 'a topology \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> 'a) \<Rightarrow> bool" where
  "singular_simplex p X f \<equiv>
       continuous_map(subtopology (powertop_real UNIV) (standard_simplex p)) X f
     \<and> f \<in> extensional (standard_simplex p)"
 
 abbreviation singular_simplex_set :: "nat \<Rightarrow> 'a topology \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> 'a) set" where
  "singular_simplex_set p X \<equiv> Collect (singular_simplex p X)"
 
 lemma singular_simplex_empty:
    "topspace X = {} \<Longrightarrow> \<not> singular_simplex p X f"
   by (simp add: singular_simplex_def continuous_map nonempty_standard_simplex)
 
 lemma singular_simplex_mono:
    "\<lbrakk>singular_simplex p (subtopology X T) f; T \<subseteq> S\<rbrakk> \<Longrightarrow> singular_simplex p (subtopology X S) f"
   by (auto simp: singular_simplex_def continuous_map_in_subtopology)
 
 lemma singular_simplex_subtopology:
    "singular_simplex p (subtopology X S) f \<longleftrightarrow>
         singular_simplex p X f \<and> f ` (standard_simplex p) \<subseteq> S"
   by (auto simp: singular_simplex_def continuous_map_in_subtopology)
 
 subsubsection\<open>Singular face\<close>
 
 definition singular_face :: "nat \<Rightarrow> nat \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> 'a"
   where "singular_face p k f \<equiv> restrict (f \<circ> simplical_face k) (standard_simplex (p - Suc 0))"
 
 lemma singular_simplex_singular_face:
   assumes f: "singular_simplex p X f" and "1 \<le> p" "k \<le> p"
   shows "singular_simplex (p - Suc 0) X (singular_face p k f)"
 proof -
   let ?PT = "(powertop_real UNIV)"
   have 0: "simplical_face k ` standard_simplex (p - Suc 0) \<subseteq> standard_simplex p"
     using assms simplical_face_in_standard_simplex by auto
   have 1: "continuous_map (subtopology ?PT (standard_simplex (p - Suc 0)))
                           (subtopology ?PT (standard_simplex p))
                           (simplical_face k)"
   proof (clarsimp simp add: continuous_map_in_subtopology simplical_face_in_standard_simplex continuous_map_componentwise 0)
     fix i
     have "continuous_map ?PT euclideanreal (\<lambda>x. if i < k then x i else if i = k then 0 else x (i -1))"
       by (auto intro: continuous_map_product_projection)
     then show "continuous_map (subtopology ?PT (standard_simplex (p - Suc 0))) euclideanreal
                               (\<lambda>x. simplical_face k x i)"
       by (simp add: simplical_face_def continuous_map_from_subtopology)
   qed
   have 2: "continuous_map (subtopology ?PT (standard_simplex p)) X f"
     using assms(1) singular_simplex_def by blast
   show ?thesis
     by (simp add: singular_simplex_def singular_face_def continuous_map_compose [OF 1 2])
 qed
 
 
 subsection\<open>Singular chains\<close>
 
 definition singular_chain :: "[nat, 'a topology, 'a chain] \<Rightarrow> bool"
   where "singular_chain p X c \<equiv> Poly_Mapping.keys c \<subseteq> singular_simplex_set p X"
 
 abbreviation singular_chain_set :: "[nat, 'a topology] \<Rightarrow> ('a chain) set"
   where "singular_chain_set p X \<equiv> Collect (singular_chain p X)"
 
 lemma singular_chain_empty:
    "topspace X = {} \<Longrightarrow> singular_chain p X c \<longleftrightarrow> c = 0"
   by (auto simp: singular_chain_def singular_simplex_empty subset_eq poly_mapping_eqI)
 
 lemma singular_chain_mono:
    "\<lbrakk>singular_chain p (subtopology X T) c;  T \<subseteq> S\<rbrakk>
         \<Longrightarrow> singular_chain p (subtopology X S) c"
   unfolding singular_chain_def using singular_simplex_mono by blast
 
 lemma singular_chain_subtopology:
    "singular_chain p (subtopology X S) c \<longleftrightarrow>
         singular_chain p X c \<and> (\<forall>f \<in> Poly_Mapping.keys c. f ` (standard_simplex p) \<subseteq> S)"
   unfolding singular_chain_def
   by (fastforce simp add: singular_simplex_subtopology subset_eq)
 
 lemma singular_chain_0 [iff]: "singular_chain p X 0"
   by (auto simp: singular_chain_def)
 
 lemma singular_chain_of:
    "singular_chain p X (frag_of c) \<longleftrightarrow> singular_simplex p X c"
   by (auto simp: singular_chain_def)
 
 lemma singular_chain_cmul:
    "singular_chain p X c \<Longrightarrow> singular_chain p X (frag_cmul a c)"
   by (auto simp: singular_chain_def)
 
 lemma singular_chain_minus:
    "singular_chain p X (-c) \<longleftrightarrow> singular_chain p X c"
   by (auto simp: singular_chain_def)
 
 lemma singular_chain_add:
    "\<lbrakk>singular_chain p X a; singular_chain p X b\<rbrakk> \<Longrightarrow> singular_chain p X (a+b)"
   unfolding singular_chain_def
   using keys_add [of a b] by blast
 
 lemma singular_chain_diff:
    "\<lbrakk>singular_chain p X a; singular_chain p X b\<rbrakk> \<Longrightarrow> singular_chain p X (a-b)"
   unfolding singular_chain_def
   using keys_diff [of a b] by blast
 
 lemma singular_chain_sum:
    "(\<And>i. i \<in> I \<Longrightarrow> singular_chain p X (f i)) \<Longrightarrow> singular_chain p X (\<Sum>i\<in>I. f i)"
   unfolding singular_chain_def
   using keys_sum [of f I] by blast
 
 lemma singular_chain_extend:
    "(\<And>c. c \<in> Poly_Mapping.keys x \<Longrightarrow> singular_chain p X (f c))
         \<Longrightarrow> singular_chain p X (frag_extend f x)"
   by (simp add: frag_extend_def singular_chain_cmul singular_chain_sum)
 
 subsection\<open>Boundary homomorphism for singular chains\<close>
 
 definition chain_boundary :: "nat \<Rightarrow> ('a chain) \<Rightarrow> 'a chain"
   where "chain_boundary p c \<equiv>
           (if p = 0 then 0 else
            frag_extend (\<lambda>f. (\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of(singular_face p k f)))) c)"
 
 lemma singular_chain_boundary:
   assumes "singular_chain p X c"
   shows "singular_chain (p - Suc 0) X (chain_boundary p c)"
   unfolding chain_boundary_def
 proof (clarsimp intro!: singular_chain_extend singular_chain_sum singular_chain_cmul)
   show "\<And>d k. \<lbrakk>0 < p; d \<in> Poly_Mapping.keys c; k \<le> p\<rbrakk>
        \<Longrightarrow> singular_chain (p - Suc 0) X (frag_of (singular_face p k d))"
     using assms by (auto simp: singular_chain_def intro: singular_simplex_singular_face)
 qed
 
 lemma singular_chain_boundary_alt:
    "singular_chain (Suc p) X c \<Longrightarrow> singular_chain p X (chain_boundary (Suc p) c)"
   using singular_chain_boundary by force
 
 lemma chain_boundary_0 [simp]: "chain_boundary p 0 = 0"
   by (simp add: chain_boundary_def)
 
 lemma chain_boundary_cmul:
    "chain_boundary p (frag_cmul k c) = frag_cmul k (chain_boundary p c)"
   by (auto simp: chain_boundary_def frag_extend_cmul)
 
 lemma chain_boundary_minus:
    "chain_boundary p (- c) = - (chain_boundary p c)"
   by (metis chain_boundary_cmul frag_cmul_minus_one)
 
 lemma chain_boundary_add:
    "chain_boundary p (a+b) = chain_boundary p a + chain_boundary p b"
   by (simp add: chain_boundary_def frag_extend_add)
 
 lemma chain_boundary_diff:
    "chain_boundary p (a-b) = chain_boundary p a - chain_boundary p b"
   using chain_boundary_add [of p a "-b"]
   by (simp add: chain_boundary_minus)
 
 lemma chain_boundary_sum:
    "chain_boundary p (sum g I) = sum (chain_boundary p \<circ> g) I"
   by (induction I rule: infinite_finite_induct) (simp_all add: chain_boundary_add)
 
 lemma chain_boundary_sum':
    "finite I \<Longrightarrow> chain_boundary p (sum' g I) = sum' (chain_boundary p \<circ> g) I"
   by (induction I rule: finite_induct) (simp_all add: chain_boundary_add)
 
 lemma chain_boundary_of:
    "chain_boundary p (frag_of f) =
         (if p = 0 then 0
          else (\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of(singular_face p k f))))"
   by (simp add: chain_boundary_def)
 
 subsection\<open>Factoring out chains in a subtopology for relative homology\<close>
 
 definition mod_subset
   where "mod_subset p X \<equiv> {(a,b). singular_chain p X (a - b)}"
 
 lemma mod_subset_empty [simp]:
    "(a,b) \<in> (mod_subset p (subtopology X {})) \<longleftrightarrow> a = b"
   by (simp add: mod_subset_def singular_chain_empty)
 
 lemma mod_subset_refl [simp]: "(c,c) \<in> mod_subset p X"
   by (auto simp: mod_subset_def)
 
 lemma mod_subset_cmul:
   assumes "(a,b) \<in> mod_subset p X"
   shows "(frag_cmul k a, frag_cmul k b) \<in> mod_subset p X"
   using assms
   by (simp add: mod_subset_def) (metis (no_types, lifting) add_diff_cancel diff_add_cancel frag_cmul_distrib2 singular_chain_cmul)
 
 lemma mod_subset_add:
    "\<lbrakk>(c1,c2) \<in> mod_subset p X; (d1,d2) \<in> mod_subset p X\<rbrakk> \<Longrightarrow> (c1+d1, c2+d2) \<in> mod_subset p X"
   by (simp add: mod_subset_def add_diff_add singular_chain_add)
 
 subsection\<open>Relative cycles $Z_pX (S)$ where $X$ is a topology and $S$ a subset \<close>
 
 definition singular_relcycle :: "nat \<Rightarrow> 'a topology \<Rightarrow> 'a set \<Rightarrow> ('a chain) \<Rightarrow> bool"
   where "singular_relcycle p X S \<equiv>
         \<lambda>c. singular_chain p X c \<and> (chain_boundary p c, 0) \<in> mod_subset (p-1) (subtopology X S)"
 
 abbreviation singular_relcycle_set
   where "singular_relcycle_set p X S \<equiv> Collect (singular_relcycle p X S)"
 
 lemma singular_relcycle_restrict [simp]:
    "singular_relcycle p X (topspace X \<inter> S) = singular_relcycle p X S"
 proof -
   have eq: "subtopology X (topspace X \<inter> S) = subtopology X S"
     by (metis subtopology_subtopology subtopology_topspace)
   show ?thesis
     by (force simp: singular_relcycle_def eq)
 qed
 
 lemma singular_relcycle:
    "singular_relcycle p X S c \<longleftrightarrow>
     singular_chain p X c \<and> singular_chain (p-1) (subtopology X S) (chain_boundary p c)"
   by (simp add: singular_relcycle_def mod_subset_def)
 
 lemma singular_relcycle_0 [simp]: "singular_relcycle p X S 0"
   by (auto simp: singular_relcycle_def)
 
 lemma singular_relcycle_cmul:
    "singular_relcycle p X S c \<Longrightarrow> singular_relcycle p X S (frag_cmul k c)"
   by (auto simp: singular_relcycle_def chain_boundary_cmul dest: singular_chain_cmul mod_subset_cmul)
 
 lemma singular_relcycle_minus:
    "singular_relcycle p X S (-c) \<longleftrightarrow> singular_relcycle p X S c"
   by (simp add: chain_boundary_minus singular_chain_minus singular_relcycle)
 
 lemma singular_relcycle_add:
    "\<lbrakk>singular_relcycle p X S a; singular_relcycle p X S b\<rbrakk>
         \<Longrightarrow> singular_relcycle p X S (a+b)"
   by (simp add: singular_relcycle_def chain_boundary_add mod_subset_def singular_chain_add)
 
 lemma singular_relcycle_sum:
    "\<lbrakk>\<And>i. i \<in> I \<Longrightarrow> singular_relcycle p X S (f i)\<rbrakk>
         \<Longrightarrow> singular_relcycle p X S (sum f I)"
   by (induction I rule: infinite_finite_induct) (auto simp: singular_relcycle_add)
 
 lemma singular_relcycle_diff:
    "\<lbrakk>singular_relcycle p X S a; singular_relcycle p X S b\<rbrakk>
         \<Longrightarrow> singular_relcycle p X S (a-b)"
   by (metis singular_relcycle_add singular_relcycle_minus uminus_add_conv_diff)
 
 lemma singular_cycle:
    "singular_relcycle p X {} c \<longleftrightarrow> singular_chain p X c \<and> chain_boundary p c = 0"
   by (simp add: singular_relcycle_def)
 
 lemma singular_cycle_mono:
    "\<lbrakk>singular_relcycle p (subtopology X T) {} c; T \<subseteq> S\<rbrakk>
         \<Longrightarrow> singular_relcycle p (subtopology X S) {} c"
   by (auto simp: singular_cycle elim: singular_chain_mono)
 
 
 subsection\<open>Relative boundaries $B_p X S$, where $X$ is a topology and $S$ a subset.\<close>
 
 definition singular_relboundary :: "nat \<Rightarrow> 'a topology \<Rightarrow> 'a set \<Rightarrow> ('a chain) \<Rightarrow> bool"
   where
   "singular_relboundary p X S \<equiv>
     \<lambda>c. \<exists>d. singular_chain (Suc p) X d \<and> (chain_boundary (Suc p) d, c) \<in> (mod_subset p (subtopology X S))"
 
 abbreviation singular_relboundary_set :: "nat \<Rightarrow> 'a topology \<Rightarrow> 'a set \<Rightarrow> ('a chain) set"
   where "singular_relboundary_set p X S \<equiv> Collect (singular_relboundary p X S)"
 
 lemma singular_relboundary_restrict [simp]:
    "singular_relboundary p X (topspace X \<inter> S) = singular_relboundary p X S"
   unfolding singular_relboundary_def
   by (metis (no_types, hide_lams) subtopology_subtopology subtopology_topspace)
 
 lemma singular_relboundary_alt:
    "singular_relboundary p X S c \<longleftrightarrow>
     (\<exists>d e. singular_chain (Suc p) X d \<and> singular_chain p (subtopology X S) e \<and>
            chain_boundary (Suc p) d = c + e)"
   unfolding singular_relboundary_def mod_subset_def by fastforce
 
 lemma singular_relboundary:
    "singular_relboundary p X S c \<longleftrightarrow>
     (\<exists>d e. singular_chain (Suc p) X d \<and> singular_chain p (subtopology X S) e \<and>
               (chain_boundary (Suc p) d) + e = c)"
   using singular_chain_minus
   by (fastforce simp add: singular_relboundary_alt)
 
 lemma singular_boundary:
    "singular_relboundary p X {} c \<longleftrightarrow>
     (\<exists>d. singular_chain (Suc p) X d \<and> chain_boundary (Suc p) d = c)"
   by (simp add: singular_relboundary_def)
 
 lemma singular_boundary_imp_chain:
    "singular_relboundary p X {} c \<Longrightarrow> singular_chain p X c"
   by (auto simp: singular_relboundary singular_chain_boundary_alt singular_chain_empty topspace_subtopology)
 
 lemma singular_boundary_mono:
    "\<lbrakk>T \<subseteq> S; singular_relboundary p (subtopology X T) {} c\<rbrakk>
         \<Longrightarrow> singular_relboundary p (subtopology X S) {} c"
   by (metis mod_subset_empty singular_chain_mono singular_relboundary_def)
 
 lemma singular_relboundary_imp_chain:
    "singular_relboundary p X S c \<Longrightarrow> singular_chain p X c"
   unfolding singular_relboundary singular_chain_subtopology
   by (blast intro: singular_chain_add singular_chain_boundary_alt)
 
 lemma singular_chain_imp_relboundary:
    "singular_chain p (subtopology X S) c \<Longrightarrow> singular_relboundary p X S c"
   unfolding singular_relboundary_def
   using mod_subset_def singular_chain_minus by fastforce
 
 lemma singular_relboundary_0 [simp]: "singular_relboundary p X S 0"
   unfolding singular_relboundary_def
   by (rule_tac x=0 in exI) auto
 
 lemma singular_relboundary_cmul:
    "singular_relboundary p X S c \<Longrightarrow> singular_relboundary p X S (frag_cmul a c)"
   unfolding singular_relboundary_def
   by (metis chain_boundary_cmul mod_subset_cmul singular_chain_cmul)
 
 lemma singular_relboundary_minus:
    "singular_relboundary p X S (-c) \<longleftrightarrow> singular_relboundary p X S c"
   using singular_relboundary_cmul
   by (metis add.inverse_inverse frag_cmul_minus_one)
 
 lemma singular_relboundary_add:
    "\<lbrakk>singular_relboundary p X S a; singular_relboundary p X S b\<rbrakk> \<Longrightarrow> singular_relboundary p X S (a+b)"
   unfolding singular_relboundary_def
   by (metis chain_boundary_add mod_subset_add singular_chain_add)
 
 lemma singular_relboundary_diff:
    "\<lbrakk>singular_relboundary p X S a; singular_relboundary p X S b\<rbrakk> \<Longrightarrow> singular_relboundary p X S (a-b)"
   by (metis uminus_add_conv_diff singular_relboundary_minus singular_relboundary_add)
 
 subsection\<open>The (relative) homology relation\<close>
 
 definition homologous_rel :: "[nat,'a topology,'a set,'a chain,'a chain] \<Rightarrow> bool"
   where "homologous_rel p X S \<equiv> \<lambda>a b. singular_relboundary p X S (a-b)"
 
 abbreviation homologous_rel_set
   where "homologous_rel_set p X S a \<equiv> Collect (homologous_rel p X S a)"
 
 lemma homologous_rel_restrict [simp]:
    "homologous_rel p X (topspace X \<inter> S) = homologous_rel p X S"
   unfolding homologous_rel_def by (metis singular_relboundary_restrict)
 
 lemma homologous_rel_refl [simp]: "homologous_rel p X S c c"
   unfolding homologous_rel_def by auto
 
 lemma homologous_rel_sym:
    "homologous_rel p X S a b = homologous_rel p X S b a"
   unfolding homologous_rel_def
   using singular_relboundary_minus by fastforce
 
 lemma homologous_rel_trans:
   assumes "homologous_rel p X S b c" "homologous_rel p X S a b"
   shows "homologous_rel p X S a c"
   using homologous_rel_def
 proof -
   have "singular_relboundary p X S (b - c)"
     using assms unfolding homologous_rel_def by blast
   moreover have "singular_relboundary p X S (b - a)"
     using assms by (meson homologous_rel_def homologous_rel_sym)
   ultimately have "singular_relboundary p X S (c - a)"
     using singular_relboundary_diff by fastforce
   then show ?thesis
     by (meson homologous_rel_def homologous_rel_sym)
 qed
 
 lemma homologous_rel_eq:
    "homologous_rel p X S a = homologous_rel p X S b \<longleftrightarrow>
     homologous_rel p X S a b"
   using homologous_rel_sym homologous_rel_trans by fastforce
 
 lemma homologous_rel_set_eq:
    "homologous_rel_set p X S a = homologous_rel_set p X S b \<longleftrightarrow>
     homologous_rel p X S a b"
   by (metis homologous_rel_eq mem_Collect_eq)
 
 lemma homologous_rel_singular_chain:
   "homologous_rel p X S a b \<Longrightarrow> (singular_chain p X a \<longleftrightarrow> singular_chain p X b)"
   unfolding homologous_rel_def
   using singular_chain_diff singular_chain_add
   by (fastforce dest: singular_relboundary_imp_chain)
 
 lemma homologous_rel_add:
    "\<lbrakk>homologous_rel p X S a a'; homologous_rel p X S b b'\<rbrakk>
         \<Longrightarrow> homologous_rel p X S (a+b) (a'+b')"
   unfolding homologous_rel_def
   by (simp add: add_diff_add singular_relboundary_add)
 
 lemma homologous_rel_diff:
   assumes "homologous_rel p X S a a'" "homologous_rel p X S b b'"
   shows "homologous_rel p X S (a - b) (a' - b')"
 proof -
   have "singular_relboundary p X S ((a - a') - (b - b'))"
     using assms singular_relboundary_diff unfolding homologous_rel_def by blast
   then show ?thesis
     by (simp add: homologous_rel_def algebra_simps)
 qed
 
 lemma homologous_rel_sum:
   assumes f: "finite {i \<in> I. f i \<noteq> 0}" and g: "finite {i \<in> I. g i \<noteq> 0}"
     and h: "\<And>i. i \<in> I \<Longrightarrow> homologous_rel p X S (f i) (g i)"
   shows "homologous_rel p X S (sum f I) (sum g I)"
 proof (cases "finite I")
   case True
   let ?L = "{i \<in> I. f i \<noteq> 0} \<union> {i \<in> I. g i \<noteq> 0}"
   have L: "finite ?L" "?L \<subseteq> I"
     using f g by blast+
   have "sum f I = sum f ?L"
     by (rule comm_monoid_add_class.sum.mono_neutral_right [OF True]) auto
   moreover have "sum g I = sum g ?L"
     by (rule comm_monoid_add_class.sum.mono_neutral_right [OF True]) auto
   moreover have *: "homologous_rel p X S (f i) (g i)" if "i \<in> ?L" for i
     using h that by auto
   have "homologous_rel p X S (sum f ?L) (sum g ?L)"
     using L
   proof induction
     case (insert j J)
     then show ?case
       by (simp add: h homologous_rel_add)
   qed auto
   ultimately show ?thesis
     by simp
 qed auto
 
 
 lemma chain_homotopic_imp_homologous_rel:
   assumes
    "\<And>c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X' (h c)"
    "\<And>c. singular_chain (p -1) (subtopology X S) c \<Longrightarrow> singular_chain p (subtopology X' T) (h' c)"
    "\<And>c. singular_chain p X c
              \<Longrightarrow> (chain_boundary (Suc p) (h c)) + (h'(chain_boundary p c)) = f c - g c"
     "singular_relcycle p X S c"
   shows "homologous_rel p X' T (f c) (g c)"
 proof -
   have "singular_chain p (subtopology X' T) (chain_boundary (Suc p) (h c) - (f c - g c))"
     using assms
     by (metis (no_types, lifting) add_diff_cancel_left' minus_diff_eq singular_chain_minus singular_relcycle)
   then show ?thesis
   using assms
     by (metis homologous_rel_def singular_relboundary singular_relcycle)
 qed
 
 
 subsection\<open>Show that all boundaries are cycles, the key "chain complex" property.\<close>
 
 lemma chain_boundary_boundary:
   assumes "singular_chain p X c"
   shows "chain_boundary (p - Suc 0) (chain_boundary p c) = 0"
 proof (cases "p -1 = 0")
   case False
   then have "2 \<le> p"
     by auto
   show ?thesis
     using assms
     unfolding singular_chain_def
   proof (induction rule: frag_induction)
     case (one g)
     then have ss: "singular_simplex p X g"
       by simp
     have eql: "{..p} \<times> {..p - Suc 0} \<inter> {(x, y). y < x} = (\<lambda>(j,i). (Suc i, j)) ` {(i,j). i \<le> j \<and> j \<le> p -1}"
       using False
       by (auto simp: image_def) (metis One_nat_def diff_Suc_1 diff_le_mono le_refl lessE less_imp_le_nat)
     have eqr: "{..p} \<times> {..p - Suc 0} - {(x, y). y < x} = {(i,j). i \<le> j \<and> j \<le> p -1}"
       by auto
     have eqf: "singular_face (p - Suc 0) i (singular_face p (Suc j) g) =
                singular_face (p - Suc 0) j (singular_face p i g)" if "i \<le> j" "j \<le> p - Suc 0" for i j
     proof (rule ext)
       fix t
       show "singular_face (p - Suc 0) i (singular_face p (Suc j) g) t =
             singular_face (p - Suc 0) j (singular_face p i g) t"
       proof (cases "t \<in> standard_simplex (p -1 -1)")
         case True
         have fi: "simplical_face i t \<in> standard_simplex (p - Suc 0)"
           using False True simplical_face_in_standard_simplex that by force
         have fj: "simplical_face j t \<in> standard_simplex (p - Suc 0)"
           by (metis False One_nat_def True simplical_face_in_standard_simplex less_one not_less that(2))
         have eq: "simplical_face (Suc j) (simplical_face i t) = simplical_face i (simplical_face j t)"
           using True that ss
           unfolding standard_simplex_def simplical_face_def by fastforce
         show ?thesis by (simp add: singular_face_def fi fj eq)
       qed (simp add: singular_face_def)
     qed
     show ?case
     proof (cases "p = 1")
       case False
       have eq0: "frag_cmul (-1) a = b \<Longrightarrow> a + b = 0" for a b
         by (simp add: neg_eq_iff_add_eq_0)
       have *: "(\<Sum>x\<le>p. \<Sum>i\<le>p - Suc 0.
                  frag_cmul ((-1) ^ (x + i)) (frag_of (singular_face (p - Suc 0) i (singular_face p x g))))
               = 0"
         apply (simp add: sum.cartesian_product sum.Int_Diff [of "_ \<times> _" _ "{(x,y). y < x}"])
         apply (rule eq0)
         unfolding frag_cmul_sum prod.case_distrib [of "frag_cmul (-1)"] frag_cmul_cmul eql eqr 
         apply (force simp: inj_on_def sum.reindex add.commute eqf intro: sum.cong)
         done
       show ?thesis
         using False by (simp add: chain_boundary_of chain_boundary_sum chain_boundary_cmul frag_cmul_sum * flip: power_add)
     qed (simp add: chain_boundary_def)
   next
     case (diff a b)
     then show ?case
       by (simp add: chain_boundary_diff)
   qed auto
 qed (simp add: chain_boundary_def)
 
 
 lemma chain_boundary_boundary_alt:
    "singular_chain (Suc p) X c \<Longrightarrow> chain_boundary p (chain_boundary (Suc p) c) = 0"
   using chain_boundary_boundary by force
 
 lemma singular_relboundary_imp_relcycle:
   assumes "singular_relboundary p X S c"
   shows "singular_relcycle p X S c"
 proof -
   obtain d e where d: "singular_chain (Suc p) X d"
                and e: "singular_chain p (subtopology X S) e"
                and c: "c = chain_boundary (Suc p) d + e"
     using assms by (auto simp: singular_relboundary singular_relcycle)
   have 1: "singular_chain (p - Suc 0) (subtopology X S) (chain_boundary p (chain_boundary (Suc p) d))"
     using d chain_boundary_boundary_alt by fastforce
   have 2: "singular_chain (p - Suc 0) (subtopology X S) (chain_boundary p e)"
     using \<open>singular_chain p (subtopology X S) e\<close> singular_chain_boundary by auto
   have "singular_chain p X c"
     using assms singular_relboundary_imp_chain by auto
   moreover have "singular_chain (p - Suc 0) (subtopology X S) (chain_boundary p c)"
     by (simp add: c chain_boundary_add singular_chain_add 1 2)
   ultimately show ?thesis
     by (simp add: singular_relcycle)
 qed
 
 lemma homologous_rel_singular_relcycle_1:
   assumes "homologous_rel p X S c1 c2" "singular_relcycle p X S c1"
   shows "singular_relcycle p X S c2"
   using assms
   by (metis diff_add_cancel homologous_rel_def homologous_rel_sym singular_relboundary_imp_relcycle singular_relcycle_add)
 
 lemma homologous_rel_singular_relcycle:
   assumes "homologous_rel p X S c1 c2"
   shows "singular_relcycle p X S c1 = singular_relcycle p X S c2"
   using assms homologous_rel_singular_relcycle_1
   using homologous_rel_sym by blast
 
 
 subsection\<open>Operations induced by a continuous map g between topological spaces\<close>
 
 definition simplex_map :: "nat \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> 'b) \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> 'a"
   where "simplex_map p g c \<equiv> restrict (g \<circ> c) (standard_simplex p)"
 
 lemma singular_simplex_simplex_map:
    "\<lbrakk>singular_simplex p X f; continuous_map X X' g\<rbrakk>
         \<Longrightarrow> singular_simplex p X' (simplex_map p g f)"
   unfolding singular_simplex_def simplex_map_def
   by (auto simp: continuous_map_compose)
 
 lemma simplex_map_eq:
    "\<lbrakk>singular_simplex p X c;
      \<And>x. x \<in> topspace X \<Longrightarrow> f x = g x\<rbrakk>
     \<Longrightarrow> simplex_map p f c = simplex_map p g c"
   by (auto simp: singular_simplex_def simplex_map_def continuous_map_def)
 
 lemma simplex_map_id_gen:
    "\<lbrakk>singular_simplex p X c;
      \<And>x. x \<in> topspace X \<Longrightarrow> f x = x\<rbrakk>
     \<Longrightarrow> simplex_map p f c = c"
   unfolding singular_simplex_def simplex_map_def continuous_map_def
   using extensional_arb by fastforce
 
 lemma simplex_map_id [simp]:
    "simplex_map p id = (\<lambda>c. restrict c (standard_simplex p))"
   by (auto simp: simplex_map_def)
 
 lemma simplex_map_compose:
    "simplex_map p (h \<circ> g) = simplex_map p h \<circ> simplex_map p g"
   unfolding simplex_map_def by force
 
 lemma singular_face_simplex_map:
    "\<lbrakk>1 \<le> p; k \<le> p\<rbrakk>
         \<Longrightarrow> singular_face p k (simplex_map p f c) = simplex_map (p - Suc 0) f (c \<circ> simplical_face k)"
   unfolding simplex_map_def singular_face_def
   by (force simp: simplical_face_in_standard_simplex)
 
 lemma singular_face_restrict [simp]:
   assumes "p > 0" "i \<le> p"
   shows "singular_face p i (restrict f (standard_simplex p)) = singular_face p i f"
   by (metis assms One_nat_def Suc_leI simplex_map_id singular_face_def singular_face_simplex_map)
 
 
 definition chain_map :: "nat \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> (((nat \<Rightarrow> real) \<Rightarrow> 'b) \<Rightarrow>\<^sub>0 int) \<Rightarrow> 'a chain"
   where "chain_map p g c \<equiv> frag_extend (frag_of \<circ> simplex_map p g) c"
 
 lemma singular_chain_chain_map:
    "\<lbrakk>singular_chain p X c; continuous_map X X' g\<rbrakk> \<Longrightarrow> singular_chain p X' (chain_map p g c)"
   unfolding chain_map_def
   by (force simp add: singular_chain_def subset_iff 
       intro!: singular_chain_extend singular_simplex_simplex_map)
 
 lemma chain_map_0 [simp]: "chain_map p g 0 = 0"
   by (auto simp: chain_map_def)
 
 lemma chain_map_of [simp]: "chain_map p g (frag_of f) = frag_of (simplex_map p g f)"
   by (simp add: chain_map_def)
 
 lemma chain_map_cmul [simp]:
    "chain_map p g (frag_cmul a c) = frag_cmul a (chain_map p g c)"
   by (simp add: frag_extend_cmul chain_map_def)
 
 lemma chain_map_minus: "chain_map p g (-c) = - (chain_map p g c)"
   by (simp add: frag_extend_minus chain_map_def)
 
 lemma chain_map_add:
    "chain_map p g (a+b) = chain_map p g a + chain_map p g b"
   by (simp add: frag_extend_add chain_map_def)
 
 lemma chain_map_diff:
    "chain_map p g (a-b) = chain_map p g a - chain_map p g b"
   by (simp add: frag_extend_diff chain_map_def)
 
 lemma chain_map_sum:
    "finite I \<Longrightarrow> chain_map p g (sum f I) = sum (chain_map p g \<circ> f) I"
   by (simp add: frag_extend_sum chain_map_def)
 
 lemma chain_map_eq:
    "\<lbrakk>singular_chain p X c; \<And>x. x \<in> topspace X \<Longrightarrow> f x = g x\<rbrakk>
     \<Longrightarrow> chain_map p f c = chain_map p g c"
   unfolding singular_chain_def
 proof (induction rule: frag_induction)
   case (one x)
   then show ?case
     by (metis (no_types, lifting) chain_map_of mem_Collect_eq simplex_map_eq)
 qed (auto simp: chain_map_diff)
 
 lemma chain_map_id_gen:
    "\<lbrakk>singular_chain p X c; \<And>x. x \<in> topspace X \<Longrightarrow> f x = x\<rbrakk>
     \<Longrightarrow>  chain_map p f c = c"
   unfolding singular_chain_def
   by (erule frag_induction) (auto simp: chain_map_diff simplex_map_id_gen)
 
 lemma chain_map_ident:
    "singular_chain p X c \<Longrightarrow> chain_map p id c = c"
   by (simp add: chain_map_id_gen)
 
 lemma chain_map_id:
    "chain_map p id = frag_extend (frag_of \<circ> (\<lambda>f. restrict f (standard_simplex p)))"
   by (auto simp: chain_map_def)
 
 lemma chain_map_compose:
    "chain_map p (h \<circ> g) = chain_map p h \<circ> chain_map p g"
 proof
   show "chain_map p (h \<circ> g) c = (chain_map p h \<circ> chain_map p g) c" for c
     using subset_UNIV
   proof (induction c rule: frag_induction)
     case (one x)
     then show ?case
       by simp (metis (mono_tags, lifting) comp_eq_dest_lhs restrict_apply simplex_map_def)
   next
     case (diff a b)
     then show ?case
       by (simp add: chain_map_diff)
   qed auto
 qed
 
 lemma singular_simplex_chain_map_id:
   assumes "singular_simplex p X f"
   shows "chain_map p f (frag_of (restrict id (standard_simplex p))) = frag_of f"
 proof -
   have "(restrict (f \<circ> restrict id (standard_simplex p)) (standard_simplex p)) = f"
     by (rule ext) (metis assms comp_apply extensional_arb id_apply restrict_apply singular_simplex_def)
   then show ?thesis
     by (simp add: simplex_map_def)
 qed
 
 lemma chain_boundary_chain_map:
   assumes "singular_chain p X c"
   shows "chain_boundary p (chain_map p g c) = chain_map (p - Suc 0) g (chain_boundary p c)"
   using assms unfolding singular_chain_def
 proof (induction c rule: frag_induction)
   case (one x)
   then have "singular_face p i (simplex_map p g x) = simplex_map (p - Suc 0) g (singular_face p i x)"
     if "0 \<le> i" "i \<le> p" "p \<noteq> 0" for i
     using that
     by (fastforce simp add: singular_face_def simplex_map_def simplical_face_in_standard_simplex)
   then show ?case
     by (auto simp: chain_boundary_of chain_map_sum)
 next
   case (diff a b)
   then show ?case
     by (simp add: chain_boundary_diff chain_map_diff)
 qed auto
 
 lemma singular_relcycle_chain_map:
   assumes "singular_relcycle p X S c" "continuous_map X X' g" "g ` S \<subseteq> T"
   shows "singular_relcycle p X' T (chain_map p g c)"
 proof -
   have "continuous_map (subtopology X S) (subtopology X' T) g"
     using assms
     using continuous_map_from_subtopology continuous_map_in_subtopology topspace_subtopology by fastforce
   then show ?thesis
     using chain_boundary_chain_map [of p X c g]
     by (metis One_nat_def assms(1) assms(2) singular_chain_chain_map singular_relcycle)
 qed
 
 lemma singular_relboundary_chain_map:
   assumes "singular_relboundary p X S c" "continuous_map X X' g" "g ` S \<subseteq> T"
   shows "singular_relboundary p X' T (chain_map p g c)"
 proof -
   obtain d e where d: "singular_chain (Suc p) X d"
     and e: "singular_chain p (subtopology X S) e" and c: "c = chain_boundary (Suc p) d + e"
     using assms by (auto simp: singular_relboundary)
   have "singular_chain (Suc p) X' (chain_map (Suc p) g d)"
     using assms(2) d singular_chain_chain_map by blast
   moreover have "singular_chain p (subtopology X' T) (chain_map p g e)"
   proof -
     have "\<forall>t. g ` topspace (subtopology t S) \<subseteq> T"
       by (metis assms(3) closure_of_subset_subtopology closure_of_topspace dual_order.trans image_mono)
     then show ?thesis
       by (meson assms(2) continuous_map_from_subtopology continuous_map_in_subtopology e singular_chain_chain_map)
   qed
   moreover have "chain_boundary (Suc p) (chain_map (Suc p) g d) + chain_map p g e =
                  chain_map p g (chain_boundary (Suc p) d + e)"
     by (metis One_nat_def chain_boundary_chain_map chain_map_add d diff_Suc_1)
   ultimately show ?thesis
     unfolding singular_relboundary
     using c by blast
 qed
 
 
 subsection\<open>Homology of one-point spaces degenerates except for $p = 0$.\<close>
 
 lemma singular_simplex_singleton:
   assumes "topspace X = {a}"
   shows "singular_simplex p X f \<longleftrightarrow> f = restrict (\<lambda>x. a) (standard_simplex p)" (is "?lhs = ?rhs")
 proof
   assume L: ?lhs
   then show ?rhs
   proof -
     have "continuous_map (subtopology (product_topology (\<lambda>n. euclideanreal) UNIV) (standard_simplex p)) X f"
       using \<open>singular_simplex p X f\<close> singular_simplex_def by blast
     then have "\<And>c. c \<notin> standard_simplex p \<or> f c = a"
       by (simp add: assms continuous_map_def)
     then show ?thesis
       by (metis (no_types) L extensional_restrict restrict_ext singular_simplex_def)
   qed
 next
   assume ?rhs
   with assms show ?lhs
     by (auto simp: singular_simplex_def topspace_subtopology)
 qed
 
 lemma singular_chain_singleton:
   assumes "topspace X = {a}"
   shows "singular_chain p X c \<longleftrightarrow>
          (\<exists>b. c = frag_cmul b (frag_of(restrict (\<lambda>x. a) (standard_simplex p))))"
     (is "?lhs = ?rhs")
 proof
   let ?f = "restrict (\<lambda>x. a) (standard_simplex p)"
   assume L: ?lhs
   with assms have "Poly_Mapping.keys c \<subseteq> {?f}"
     by (auto simp: singular_chain_def singular_simplex_singleton)
   then consider "Poly_Mapping.keys c = {}" | "Poly_Mapping.keys c = {?f}"
     by blast
   then show ?rhs
   proof cases
     case 1
     with L show ?thesis
       by (metis frag_cmul_zero keys_eq_empty)
   next
     case 2
     then have "\<exists>b. frag_extend frag_of c = frag_cmul b (frag_of (\<lambda>x\<in>standard_simplex p. a))"
       by (force simp: frag_extend_def)
     then show ?thesis
       by (metis frag_expansion)
   qed
 next
   assume ?rhs
   with assms show ?lhs
     by (auto simp: singular_chain_def singular_simplex_singleton)
 qed
 
 lemma chain_boundary_of_singleton:
   assumes tX: "topspace X = {a}" and sc: "singular_chain p X c"
   shows "chain_boundary p c =
          (if p = 0 \<or> odd p then 0
           else frag_extend (\<lambda>f. frag_of(restrict (\<lambda>x. a) (standard_simplex (p -1)))) c)"
     (is "?lhs = ?rhs")
 proof (cases "p = 0")
   case False
   have "?lhs = frag_extend (\<lambda>f. if odd p then 0 else frag_of(restrict (\<lambda>x. a) (standard_simplex (p -1)))) c"
   proof (simp only: chain_boundary_def False if_False, rule frag_extend_eq)
     fix f
     assume "f \<in> Poly_Mapping.keys c"
     with assms have "singular_simplex p X f"
       by (auto simp: singular_chain_def)
     then have *: "\<And>k. k \<le> p \<Longrightarrow> singular_face p k f = (\<lambda>x\<in>standard_simplex (p -1). a)"
       using False singular_simplex_singular_face 
       by (fastforce simp flip: singular_simplex_singleton [OF tX])
     define c where "c \<equiv> frag_of (\<lambda>x\<in>standard_simplex (p -1). a)"
     have "(\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of (singular_face p k f)))
         = (\<Sum>k\<le>p. frag_cmul ((-1) ^ k) c)"
       by (auto simp: c_def * intro: sum.cong)
     also have "\<dots> = (if odd p then 0 else c)"
       by (induction p) (auto simp: c_def restrict_def)
     finally show "(\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of (singular_face p k f)))
                 = (if odd p then 0 else frag_of (\<lambda>x\<in>standard_simplex (p -1). a))"
       unfolding c_def .
   qed
   also have "\<dots> = ?rhs"
     by (auto simp: False frag_extend_eq_0)
   finally show ?thesis .
 qed (simp add: chain_boundary_def)
 
 
 lemma singular_cycle_singleton:
   assumes "topspace X = {a}"
   shows "singular_relcycle p X {} c \<longleftrightarrow> singular_chain p X c \<and> (p = 0 \<or> odd p \<or> c = 0)"
 proof -
   have "c = 0" if "singular_chain p X c" and "chain_boundary p c = 0" and "even p" and "p \<noteq> 0"
     using that assms singular_chain_singleton [of X a p c] chain_boundary_of_singleton [OF assms]
     by (auto simp: frag_extend_cmul)
   moreover
   have "chain_boundary p c = 0" if sc: "singular_chain p X c" and "odd p"
     by (simp add: chain_boundary_of_singleton [OF assms sc] that)
   moreover have "chain_boundary 0 c = 0" if "singular_chain 0 X c" and "p = 0"
     by (simp add: chain_boundary_def)
   ultimately show ?thesis
   using assms by (auto simp: singular_cycle)
 qed
 
 
 lemma singular_boundary_singleton:
   assumes "topspace X = {a}"
   shows "singular_relboundary p X {} c \<longleftrightarrow> singular_chain p X c \<and> (odd p \<or> c = 0)"
 proof (cases "singular_chain p X c")
   case True
   have "\<exists>d. singular_chain (Suc p) X d \<and> chain_boundary (Suc p) d = c"
     if "singular_chain p X c" and "odd p"
   proof -
     obtain b where b: "c = frag_cmul b (frag_of(restrict (\<lambda>x. a) (standard_simplex p)))"
       by (metis True assms singular_chain_singleton)
     let ?d = "frag_cmul b (frag_of (\<lambda>x\<in>standard_simplex (Suc p). a))"
     have scd: "singular_chain (Suc p) X ?d"
       by (metis assms singular_chain_singleton)
     moreover have "chain_boundary (Suc p) ?d = c"
       by (simp add: assms scd chain_boundary_of_singleton [of X a "Suc p"] b frag_extend_cmul \<open>odd p\<close>)
     ultimately show ?thesis
       by metis
   qed
   with True assms show ?thesis
     by (auto simp: singular_boundary chain_boundary_of_singleton)
 next
   case False
   with assms singular_boundary_imp_chain show ?thesis
     by metis
 qed
 
 
 lemma singular_boundary_eq_cycle_singleton:
   assumes "topspace X = {a}" "1 \<le> p"
   shows "singular_relboundary p X {} c \<longleftrightarrow> singular_relcycle p X {} c" (is "?lhs = ?rhs")
 proof
   show "?lhs \<Longrightarrow> ?rhs"
     by (simp add: singular_relboundary_imp_relcycle)
   show "?rhs \<Longrightarrow> ?lhs"
     by (metis assms not_one_le_zero singular_boundary_singleton singular_cycle_singleton)
 qed
 
 lemma singular_boundary_set_eq_cycle_singleton:
   assumes "topspace X = {a}" "1 \<le> p"
   shows "singular_relboundary_set p X {} = singular_relcycle_set p X {}"
   using singular_boundary_eq_cycle_singleton [OF assms]
   by blast
 
 subsection\<open>Simplicial chains\<close>
 
 text\<open>Simplicial chains, effectively those resulting from linear maps.
  We still allow the map to be singular, so the name is questionable.
 These are intended as building-blocks for singular subdivision, rather  than as a axis
 for 1 simplicial homology.\<close>
 
 definition oriented_simplex
   where "oriented_simplex p l \<equiv> (\<lambda>x\<in>standard_simplex p. \<lambda>i. (\<Sum>j\<le>p. l j i * x j))"
 
 definition simplicial_simplex
   where
  "simplicial_simplex p S f \<equiv>
         singular_simplex p (subtopology (powertop_real UNIV) S) f \<and>
         (\<exists>l. f = oriented_simplex p l)"
 
 lemma simplicial_simplex:
   "simplicial_simplex p S f \<longleftrightarrow> f ` (standard_simplex p) \<subseteq> S \<and> (\<exists>l. f = oriented_simplex p l)"
   (is "?lhs = ?rhs")
 proof
   assume R: ?rhs  
   have "continuous_map (subtopology (powertop_real UNIV) (standard_simplex p))
                 (powertop_real UNIV) (\<lambda>x i. \<Sum>j\<le>p. l j i * x j)" for l :: " nat \<Rightarrow> 'a \<Rightarrow> real"
     unfolding continuous_map_componentwise
     by (force intro: continuous_intros continuous_map_from_subtopology continuous_map_product_projection)
   with R show ?lhs
     unfolding simplicial_simplex_def singular_simplex_subtopology
     by (auto simp add: singular_simplex_def oriented_simplex_def)
 qed (simp add: simplicial_simplex_def singular_simplex_subtopology)
 
 lemma simplicial_simplex_empty [simp]: "\<not> simplicial_simplex p {} f"
   by (simp add: nonempty_standard_simplex simplicial_simplex)
 
 definition simplicial_chain
   where "simplicial_chain p S c \<equiv> Poly_Mapping.keys c \<subseteq> Collect (simplicial_simplex p S)"
 
 lemma simplicial_chain_0 [simp]: "simplicial_chain p S 0"
   by (simp add: simplicial_chain_def)
 
 lemma simplicial_chain_of [simp]:
    "simplicial_chain p S (frag_of c) \<longleftrightarrow> simplicial_simplex p S c"
   by (simp add: simplicial_chain_def)
 
 lemma simplicial_chain_cmul:
    "simplicial_chain p S c \<Longrightarrow> simplicial_chain p S (frag_cmul a c)"
   by (auto simp: simplicial_chain_def)
 
 lemma simplicial_chain_diff:
    "\<lbrakk>simplicial_chain p S c1; simplicial_chain p S c2\<rbrakk> \<Longrightarrow> simplicial_chain p S (c1 - c2)"
   unfolding simplicial_chain_def  by (meson UnE keys_diff subset_iff)
 
 lemma simplicial_chain_sum:
    "(\<And>i. i \<in> I \<Longrightarrow> simplicial_chain p S (f i)) \<Longrightarrow> simplicial_chain p S (sum f I)"
   unfolding simplicial_chain_def
   using order_trans [OF keys_sum [of f I]]
   by (simp add: UN_least)
 
 lemma simplicial_simplex_oriented_simplex:
    "simplicial_simplex p S (oriented_simplex p l)
     \<longleftrightarrow> ((\<lambda>x i. \<Sum>j\<le>p. l j i * x j) ` standard_simplex p \<subseteq> S)"
   by (auto simp: simplicial_simplex oriented_simplex_def)
 
 lemma simplicial_imp_singular_simplex:
    "simplicial_simplex p S f
       \<Longrightarrow> singular_simplex p (subtopology (powertop_real UNIV) S) f"
   by (simp add: simplicial_simplex_def)
 
 lemma simplicial_imp_singular_chain:
    "simplicial_chain p S c
       \<Longrightarrow> singular_chain p (subtopology (powertop_real UNIV) S) c"
   unfolding simplicial_chain_def singular_chain_def
   by (auto intro: simplicial_imp_singular_simplex)
 
 lemma oriented_simplex_eq:
   "oriented_simplex p l = oriented_simplex p l' \<longleftrightarrow> (\<forall>i. i \<le> p \<longrightarrow> l i = l' i)"
   (is "?lhs = ?rhs")
 proof
   assume L: ?lhs
   show ?rhs
   proof clarify
     fix i
     assume "i \<le> p"
     let ?fi = "(\<lambda>j. if j = i then 1 else 0)"
     have "(\<Sum>j\<le>p. l j k * ?fi j) = (\<Sum>j\<le>p. l' j k * ?fi j)" for k
       using L \<open>i \<le> p\<close>
       by (simp add: fun_eq_iff oriented_simplex_def split: if_split_asm)
     with \<open>i \<le> p\<close> show "l i = l' i"
       by (simp add: if_distrib ext cong: if_cong)
   qed
 qed (auto simp: oriented_simplex_def)
 
 lemma singular_face_oriented_simplex:
   assumes "1 \<le> p" "k \<le> p"
   shows "singular_face p k (oriented_simplex p l) =
          oriented_simplex (p -1) (\<lambda>j. if j < k then l j else l (Suc j))"
 proof -
   have "(\<Sum>j\<le>p. l j i * simplical_face k x j)
       = (\<Sum>j\<le>p - Suc 0. (if j < k then l j else l (Suc j)) i * x j)"
     if "x \<in> standard_simplex (p - Suc 0)" for i x
   proof -
     show ?thesis
       unfolding simplical_face_def
       using sum.zero_middle [OF assms, where 'a=real, symmetric]
       by (simp add: if_distrib [of "\<lambda>x. _ * x"] if_distrib [of "\<lambda>f. f i * _"] atLeast0AtMost cong: if_cong)
   qed
   then show ?thesis
     using simplical_face_in_standard_simplex assms
     by (auto simp: singular_face_def oriented_simplex_def restrict_def)
 qed
 
 lemma simplicial_simplex_singular_face:
   fixes f :: "(nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> real"
   assumes ss: "simplicial_simplex p S f" and p: "1 \<le> p" "k \<le> p"
   shows "simplicial_simplex (p - Suc 0) S (singular_face p k f)"
 proof -
   let ?X = "subtopology (powertop_real UNIV) S"
   obtain m where l: "singular_simplex p ?X (oriented_simplex p m)"
        and feq: "f = oriented_simplex p m"
     using assms by (force simp: simplicial_simplex_def)
   moreover   
   have "singular_face p k f = oriented_simplex (p - Suc 0) (\<lambda>i. if i < k then m i else m (Suc i))"
     unfolding feq singular_face_def oriented_simplex_def
     apply (simp add: simplical_face_in_standard_simplex [OF p] restrict_compose_left subset_eq)
     using sum.zero_middle [OF p, where 'a=real, symmetric]  unfolding simplical_face_def o_def
     apply (simp add: if_distrib [of "\<lambda>x. _ * x"] if_distrib [of "\<lambda>f. f _ * _"] atLeast0AtMost cong: if_cong)
     done
   ultimately
   show ?thesis
     using p simplicial_simplex_def singular_simplex_singular_face by blast
 qed
 
 lemma simplicial_chain_boundary:
    "simplicial_chain p S c \<Longrightarrow> simplicial_chain (p -1) S (chain_boundary p c)"
   unfolding simplicial_chain_def
 proof (induction rule: frag_induction)
   case (one f)
   then have "simplicial_simplex p S f"
     by simp
   have "simplicial_chain (p - Suc 0) S (frag_of (singular_face p i f))"
     if "0 < p" "i \<le> p" for i
     using that one
     by (force simp: simplicial_simplex_def singular_simplex_singular_face singular_face_oriented_simplex)
   then have "simplicial_chain (p - Suc 0) S (chain_boundary p (frag_of f))"
     unfolding chain_boundary_def frag_extend_of
     by (auto intro!: simplicial_chain_cmul simplicial_chain_sum)
   then show ?case
     by (simp add: simplicial_chain_def [symmetric])
 next
   case (diff a b)
   then show ?case
     by (metis chain_boundary_diff simplicial_chain_def simplicial_chain_diff)
 qed auto
 
 
 subsection\<open>The cone construction on simplicial simplices.\<close>
 
 consts simplex_cone :: "[nat, nat \<Rightarrow> real, [nat \<Rightarrow> real, nat] \<Rightarrow> real, nat \<Rightarrow> real, nat] \<Rightarrow> real"
 specification (simplex_cone)
   simplex_cone:
     "\<And>p v l. simplex_cone p v (oriented_simplex p l) =
           oriented_simplex (Suc p) (\<lambda>i. if i = 0 then v else l(i -1))"
 proof -
   have *: "\<And>x. \<exists>y. \<forall>v. (\<lambda>l. oriented_simplex (Suc x) (\<lambda>i. if i = 0 then v else l (i -1)))
                   = (y v \<circ> (oriented_simplex x))"
     apply (subst choice_iff [symmetric])
     by (simp add: oriented_simplex_eq  choice_iff [symmetric] function_factors_left [symmetric])
   then show ?thesis
     unfolding o_def by (metis(no_types))
 qed
 
 lemma simplicial_simplex_simplex_cone:
   assumes f: "simplicial_simplex p S f"
     and T: "\<And>x u. \<lbrakk>0 \<le> u; u \<le> 1; x \<in> S\<rbrakk> \<Longrightarrow> (\<lambda>i. (1 - u) * v i + u * x i) \<in> T"
   shows "simplicial_simplex (Suc p) T (simplex_cone p v f)"
 proof -
   obtain l where l: "\<And>x. x \<in> standard_simplex p \<Longrightarrow> oriented_simplex p l x \<in> S"
     and feq: "f = oriented_simplex p l"
     using f by (auto simp: simplicial_simplex)
   have "oriented_simplex p l x \<in> S" if "x \<in> standard_simplex p" for x
     using f that by (auto simp: simplicial_simplex feq)
   then have S: "\<And>x. \<lbrakk>\<And>i. 0 \<le> x i \<and> x i \<le> 1; \<And>i. i>p \<Longrightarrow> x i = 0; sum x {..p} = 1\<rbrakk>
                  \<Longrightarrow> (\<lambda>i. \<Sum>j\<le>p. l j i * x j) \<in> S"
     by (simp add: oriented_simplex_def standard_simplex_def)
   have "oriented_simplex (Suc p) (\<lambda>i. if i = 0 then v else l (i -1)) x \<in> T"
     if "x \<in> standard_simplex (Suc p)" for x
   proof (simp add: that oriented_simplex_def sum.atMost_Suc_shift del: sum.atMost_Suc)
     have x01: "\<And>i. 0 \<le> x i \<and> x i \<le> 1" and x0: "\<And>i. i > Suc p \<Longrightarrow> x i = 0" and x1: "sum x {..Suc p} = 1"
       using that by (auto simp: oriented_simplex_def standard_simplex_def)
     obtain a where "a \<in> S"
       using f by force
     show "(\<lambda>i. v i * x 0 + (\<Sum>j\<le>p. l j i * x (Suc j))) \<in> T"
     proof (cases "x 0 = 1")
       case True
       then have "sum x {Suc 0..Suc p} = 0"
         using x1 by (simp add: atMost_atLeast0 sum.atLeast_Suc_atMost)
       then have [simp]: "x (Suc j) = 0" if "j\<le>p" for j
         unfolding sum.atLeast_Suc_atMost_Suc_shift
         using x01 that by (simp add: sum_nonneg_eq_0_iff)
       then show ?thesis
         using T [of 0 a] \<open>a \<in> S\<close> by (auto simp: True)
     next
       case False
       then have "(\<lambda>i. v i * x 0 + (\<Sum>j\<le>p. l j i * x (Suc j))) = (\<lambda>i. (1 - (1 - x 0)) * v i + (1 - x 0) * (inverse (1 - x 0) * (\<Sum>j\<le>p. l j i * x (Suc j))))"
         by (force simp: field_simps)
       also have "\<dots> \<in> T"
       proof (rule T)
         have "x 0 < 1"
           by (simp add: False less_le x01)
         have xle: "x (Suc i) \<le> (1 - x 0)" for i
         proof (cases "i \<le> p")
           case True
           have "sum x {0, Suc i} \<le> sum x {..Suc p}"
             by (rule sum_mono2) (auto simp: True x01)
           then show ?thesis
            using x1 x01 by (simp add: algebra_simps not_less)
         qed (simp add: x0 x01)
         have "(\<lambda>i. (\<Sum>j\<le>p. l j i * (x (Suc j) * inverse (1 - x 0)))) \<in> S"
         proof (rule S)
           have "x 0 + (\<Sum>j\<le>p. x (Suc j)) = sum x {..Suc p}"
             by (metis sum.atMost_Suc_shift)
           with x1 have "(\<Sum>j\<le>p. x (Suc j)) = 1 - x 0"
             by simp
           with False show "(\<Sum>j\<le>p. x (Suc j) * inverse (1 - x 0)) = 1"
             by (metis add_diff_cancel_left' diff_diff_eq2 diff_zero right_inverse sum_distrib_right)
       qed (use x01 x0 xle \<open>x 0 < 1\<close> in \<open>auto simp: field_split_simps\<close>)
       then show "(\<lambda>i. inverse (1 - x 0) * (\<Sum>j\<le>p. l j i * x (Suc j))) \<in> S"
         by (simp add: field_simps sum_divide_distrib)
     qed (use x01 in auto)
     finally show ?thesis .
   qed
 qed
   then show ?thesis
     by (auto simp: simplicial_simplex feq  simplex_cone)
 qed
 
 definition simplicial_cone
   where "simplicial_cone p v \<equiv> frag_extend (frag_of \<circ> simplex_cone p v)"
 
 lemma simplicial_chain_simplicial_cone:
   assumes c: "simplicial_chain p S c"
     and T: "\<And>x u. \<lbrakk>0 \<le> u; u \<le> 1; x \<in> S\<rbrakk> \<Longrightarrow> (\<lambda>i. (1 - u) * v i + u * x i) \<in> T"
   shows "simplicial_chain (Suc p) T (simplicial_cone p v c)"
   using c unfolding simplicial_chain_def simplicial_cone_def
 proof (induction rule: frag_induction)
   case (one x)
   then show ?case
     by (simp add: T simplicial_simplex_simplex_cone)
 next
   case (diff a b)
   then show ?case
     by (metis frag_extend_diff simplicial_chain_def simplicial_chain_diff)
 qed auto
 
 
 lemma chain_boundary_simplicial_cone_of':
   assumes "f = oriented_simplex p l"
   shows "chain_boundary (Suc p) (simplicial_cone p v (frag_of f)) =
          frag_of f
          - (if p = 0 then frag_of (\<lambda>u\<in>standard_simplex p. v)
             else simplicial_cone (p -1) v (chain_boundary p (frag_of f)))"
 proof (simp, intro impI conjI)
   assume "p = 0"
   have eq: "(oriented_simplex 0 (\<lambda>j. if j = 0 then v else l j)) = (\<lambda>u\<in>standard_simplex 0. v)"
     by (force simp: oriented_simplex_def standard_simplex_def)
   show "chain_boundary (Suc 0) (simplicial_cone 0 v (frag_of f))
         = frag_of f - frag_of (\<lambda>u\<in>standard_simplex 0. v)"
     by (simp add: assms simplicial_cone_def chain_boundary_of \<open>p = 0\<close> simplex_cone singular_face_oriented_simplex eq cong: if_cong)
 next
   assume "0 < p"
   have 0: "simplex_cone (p - Suc 0) v (singular_face p x (oriented_simplex p l))
          = oriented_simplex p
               (\<lambda>j. if j < Suc x
                    then if j = 0 then v else l (j -1)
                    else if Suc j = 0 then v else l (Suc j -1))" if "x \<le> p" for x
     using \<open>0 < p\<close> that
     by (auto simp: Suc_leI singular_face_oriented_simplex simplex_cone oriented_simplex_eq)
   have 1: "frag_extend (frag_of \<circ> simplex_cone (p - Suc 0) v)
                      (\<Sum>k = 0..p. frag_cmul ((-1) ^ k) (frag_of (singular_face p k (oriented_simplex p l))))
          = - (\<Sum>k = Suc 0..Suc p. frag_cmul ((-1) ^ k)
                (frag_of (singular_face (Suc p) k (simplex_cone p v (oriented_simplex p l)))))"
     unfolding sum.atLeast_Suc_atMost_Suc_shift
     by (auto simp: 0 simplex_cone singular_face_oriented_simplex frag_extend_sum frag_extend_cmul simp flip: sum_negf)
   moreover have 2: "singular_face (Suc p) 0 (simplex_cone p v (oriented_simplex p l))
                     = oriented_simplex p l"
     by (simp add: simplex_cone singular_face_oriented_simplex)
   show "chain_boundary (Suc p) (simplicial_cone p v (frag_of f))
         = frag_of f - simplicial_cone (p - Suc 0) v (chain_boundary p (frag_of f))"
     using \<open>p > 0\<close>
     apply (simp add: assms simplicial_cone_def chain_boundary_of atMost_atLeast0 del: sum.atMost_Suc)
     apply (subst sum.atLeast_Suc_atMost [of 0])
      apply (simp_all add: 1 2 del: sum.atMost_Suc)
     done
 qed
 
 lemma chain_boundary_simplicial_cone_of:
   assumes "simplicial_simplex p S f"
   shows "chain_boundary (Suc p) (simplicial_cone p v (frag_of f)) =
          frag_of f
          - (if p = 0 then frag_of (\<lambda>u\<in>standard_simplex p. v)
             else simplicial_cone (p -1) v (chain_boundary p (frag_of f)))"
   using chain_boundary_simplicial_cone_of' assms unfolding simplicial_simplex_def
   by blast
 
 lemma chain_boundary_simplicial_cone:
   "simplicial_chain p S c
    \<Longrightarrow> chain_boundary (Suc p) (simplicial_cone p v c) =
        c - (if p = 0 then frag_extend (\<lambda>f. frag_of (\<lambda>u\<in>standard_simplex p. v)) c
             else simplicial_cone (p -1) v (chain_boundary p c))"
   unfolding simplicial_chain_def
 proof (induction rule: frag_induction)
   case (one x)
   then show ?case
     by (auto simp: chain_boundary_simplicial_cone_of)
 qed (auto simp: chain_boundary_diff simplicial_cone_def frag_extend_diff)
 
 lemma simplex_map_oriented_simplex:
   assumes l: "simplicial_simplex p (standard_simplex q) (oriented_simplex p l)"
     and g: "simplicial_simplex r S g" and "q \<le> r"
   shows "simplex_map p g (oriented_simplex p l) = oriented_simplex p (g \<circ> l)"
 proof -
   obtain m where geq: "g = oriented_simplex r m"
     using g by (auto simp: simplicial_simplex_def)
   have "g (\<lambda>i. \<Sum>j\<le>p. l j i * x j) i = (\<Sum>j\<le>p. g (l j) i * x j)"
     if "x \<in> standard_simplex p" for x i
   proof -
     have ssr: "(\<lambda>i. \<Sum>j\<le>p. l j i * x j) \<in> standard_simplex r"
       using l that standard_simplex_mono [OF \<open>q \<le> r\<close>]
       unfolding simplicial_simplex_oriented_simplex by auto
     have lss: "l j \<in> standard_simplex r" if "j\<le>p" for j
     proof -
       have q: "(\<lambda>x i. \<Sum>j\<le>p. l j i * x j) ` standard_simplex p \<subseteq> standard_simplex q"
         using l by (simp add: simplicial_simplex_oriented_simplex)
       let ?x = "(\<lambda>i. if i = j then 1 else 0)"
       have p: "l j \<in> (\<lambda>x i. \<Sum>j\<le>p. l j i * x j) ` standard_simplex p"
       proof
         show "l j = (\<lambda>i. \<Sum>j\<le>p. l j i * ?x j)"
           using \<open>j\<le>p\<close> by (force simp: if_distrib cong: if_cong)
         show "?x \<in> standard_simplex p"
           by (simp add: that)
       qed
       show ?thesis
         using standard_simplex_mono [OF \<open>q \<le> r\<close>] q p
         by blast
     qed
     have "g (\<lambda>i. \<Sum>j\<le>p. l j i * x j) i = (\<Sum>j\<le>r. \<Sum>n\<le>p. m j i * (l n j * x n))"
       by (simp add: geq oriented_simplex_def sum_distrib_left ssr)
     also have "... =  (\<Sum>j\<le>p. \<Sum>n\<le>r. m n i * (l j n * x j))"
       by (rule sum.swap)
     also have "... = (\<Sum>j\<le>p. g (l j) i * x j)"
       by (simp add: geq oriented_simplex_def sum_distrib_right mult.assoc lss)
     finally show ?thesis .
   qed
   then show ?thesis
     by (force simp: oriented_simplex_def simplex_map_def o_def)
 qed
 
 
 lemma chain_map_simplicial_cone:
   assumes g: "simplicial_simplex r S g"
       and c: "simplicial_chain p (standard_simplex q) c"
       and v: "v \<in> standard_simplex q" and "q \<le> r"
   shows "chain_map (Suc p) g (simplicial_cone p v c) = simplicial_cone p (g v) (chain_map p g c)"
 proof -
   have *: "simplex_map (Suc p) g (simplex_cone p v f) = simplex_cone p (g v) (simplex_map p g f)"
     if "f \<in> Poly_Mapping.keys c" for f
   proof -
     have "simplicial_simplex p (standard_simplex q) f"
       using c that by (auto simp: simplicial_chain_def)
     then obtain m where feq: "f = oriented_simplex p m"
       by (auto simp: simplicial_simplex)
     have 0: "simplicial_simplex p (standard_simplex q) (oriented_simplex p m)"
       using \<open>simplicial_simplex p (standard_simplex q) f\<close> feq by blast
     then have 1: "simplicial_simplex (Suc p) (standard_simplex q)
                       (oriented_simplex (Suc p) (\<lambda>i. if i = 0 then v else m (i -1)))"
       using convex_standard_simplex v
       by (simp flip: simplex_cone add: simplicial_simplex_simplex_cone)
     show ?thesis
       using simplex_map_oriented_simplex [OF 1 g \<open>q \<le> r\<close>]
             simplex_map_oriented_simplex [of p q m r S g, OF 0 g \<open>q \<le> r\<close>]
       by (simp add: feq oriented_simplex_eq simplex_cone)
   qed
   show ?thesis
     by (auto simp: chain_map_def simplicial_cone_def frag_extend_compose * intro: frag_extend_eq)
 qed
 
 
 subsection\<open>Barycentric subdivision of a linear ("simplicial") simplex's image\<close>
 
 definition simplicial_vertex
   where "simplicial_vertex i f = f(\<lambda>j. if j = i then 1 else 0)"
 
 lemma simplicial_vertex_oriented_simplex:
    "simplicial_vertex i (oriented_simplex p l) = (if i \<le> p then l i else undefined)"
   by (simp add: simplicial_vertex_def oriented_simplex_def if_distrib cong: if_cong)
 
 
 primrec simplicial_subdivision
 where
   "simplicial_subdivision 0 = id"
 | "simplicial_subdivision (Suc p) =
      frag_extend
       (\<lambda>f. simplicial_cone p
             (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (p + 2))
             (simplicial_subdivision p (chain_boundary (Suc p) (frag_of f))))"
 
 
 lemma simplicial_subdivision_0 [simp]:
    "simplicial_subdivision p 0 = 0"
   by (induction p) auto
 
 lemma simplicial_subdivision_diff:
    "simplicial_subdivision p (c1-c2) = simplicial_subdivision p c1 - simplicial_subdivision p c2"
   by (induction p) (auto simp: frag_extend_diff)
 
 lemma simplicial_subdivision_of:
    "simplicial_subdivision p (frag_of f) =
          (if p = 0 then frag_of f
          else simplicial_cone (p -1)
                (\<lambda>i. (\<Sum>j\<le>p. simplicial_vertex j f i) / (Suc p))
                (simplicial_subdivision (p -1) (chain_boundary p (frag_of f))))"
   by (induction p) (auto simp: add.commute)
 
 
 lemma simplicial_chain_simplicial_subdivision:
    "simplicial_chain p S c
            \<Longrightarrow> simplicial_chain p S (simplicial_subdivision p c)"
 proof (induction p arbitrary: S c)
   case (Suc p)
   show ?case
     using Suc.prems [unfolded simplicial_chain_def]
   proof (induction c rule: frag_induction)
     case (one f)
     then have f: "simplicial_simplex (Suc p) S f"
       by auto
     then have "simplicial_chain p (f ` standard_simplex (Suc p))
                  (simplicial_subdivision p (chain_boundary (Suc p) (frag_of f)))"
       by (metis Suc.IH diff_Suc_1 simplicial_chain_boundary simplicial_chain_of simplicial_simplex subsetI)
     moreover
     obtain l where l: "\<And>x. x \<in> standard_simplex (Suc p) \<Longrightarrow> (\<lambda>i. (\<Sum>j\<le>Suc p. l j i * x j)) \<in> S"
       and feq: "f = oriented_simplex (Suc p) l"
       using f by (fastforce simp: simplicial_simplex oriented_simplex_def simp del: sum.atMost_Suc)
     have "(\<lambda>i. (1 - u) * ((\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (real p + 2)) + u * y i) \<in> S"
       if "0 \<le> u" "u \<le> 1" and y: "y \<in> f ` standard_simplex (Suc p)" for y u
     proof -
       obtain x where x: "x \<in> standard_simplex (Suc p)" and yeq: "y = oriented_simplex (Suc p) l x"
         using y feq by blast
       have "(\<lambda>i. \<Sum>j\<le>Suc p. l j i * ((if j \<le> Suc p then (1 - u) * inverse (p + 2) + u * x j else 0))) \<in> S"
       proof (rule l)
         have "inverse (2 + real p) \<le> 1" "(2 + real p) * ((1 - u) * inverse (2 + real p)) + u = 1"
           by (auto simp add: field_split_simps)
         then show "(\<lambda>j. if j \<le> Suc p then (1 - u) * inverse (real (p + 2)) + u * x j else 0) \<in> standard_simplex (Suc p)"
           using x \<open>0 \<le> u\<close> \<open>u \<le> 1\<close>
           by (simp add: sum.distrib standard_simplex_def linepath_le_1 flip: sum_distrib_left del: sum.atMost_Suc)
       qed
       moreover have "(\<lambda>i. \<Sum>j\<le>Suc p. l j i * ((1 - u) * inverse (2 + real p) + u * x j))
                    = (\<lambda>i. (1 - u) * (\<Sum>j\<le>Suc p. l j i) / (real p + 2) + u * (\<Sum>j\<le>Suc p. l j i * x j))"
       proof
         fix i
         have "(\<Sum>j\<le>Suc p. l j i * ((1 - u) * inverse (2 + real p) + u * x j))
             = (\<Sum>j\<le>Suc p. (1 - u) * l j i / (real p + 2) + u * l j i * x j)" (is "?lhs = _")
           by (simp add: field_simps cong: sum.cong)
         also have "\<dots> = (1 - u) * (\<Sum>j\<le>Suc p. l j i) / (real p + 2) + u * (\<Sum>j\<le>Suc p. l j i * x j)" (is "_ = ?rhs")
           by (simp add: sum_distrib_left sum.distrib sum_divide_distrib mult.assoc del: sum.atMost_Suc)
         finally show "?lhs = ?rhs" .
       qed
       ultimately show ?thesis
         using feq x yeq
         by (simp add: simplicial_vertex_oriented_simplex) (simp add: oriented_simplex_def)
     qed
     ultimately show ?case
       by (simp add: simplicial_chain_simplicial_cone)
   next
     case (diff a b)
     then show ?case
       by (metis simplicial_chain_diff simplicial_subdivision_diff)
   qed auto
 qed auto
 
 lemma chain_boundary_simplicial_subdivision:
    "simplicial_chain p S c
     \<Longrightarrow> chain_boundary p (simplicial_subdivision p c) = simplicial_subdivision (p -1) (chain_boundary p c)"
 proof (induction p arbitrary: c)
   case (Suc p)
   show ?case
     using Suc.prems [unfolded simplicial_chain_def]
   proof (induction c rule: frag_induction)
     case (one f)
     then have f: "simplicial_simplex (Suc p) S f"
       by simp
     then have "simplicial_chain p S (simplicial_subdivision p (chain_boundary (Suc p) (frag_of f)))"
       by (metis diff_Suc_1 simplicial_chain_boundary simplicial_chain_of simplicial_chain_simplicial_subdivision)
     moreover have "simplicial_chain p S (chain_boundary (Suc p) (frag_of f))"
       using one simplicial_chain_boundary simplicial_chain_of by fastforce
     moreover have "simplicial_subdivision (p - Suc 0) (chain_boundary p (chain_boundary (Suc p) (frag_of f))) = 0"
       by (metis f chain_boundary_boundary_alt simplicial_simplex_def simplicial_subdivision_0 singular_chain_of)
     ultimately show ?case
       using chain_boundary_simplicial_cone Suc
       by (auto simp: chain_boundary_of frag_extend_diff simplicial_cone_def)
   next
     case (diff a b)
     then show ?case
       by (simp add: simplicial_subdivision_diff chain_boundary_diff frag_extend_diff)
   qed auto
 qed auto
 
 
 text \<open>A MESS AND USED ONLY ONCE\<close>
 lemma simplicial_subdivision_shrinks:
    "\<lbrakk>simplicial_chain p S c;
      \<And>f x y. \<lbrakk>f \<in> Poly_Mapping.keys c; x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk> \<Longrightarrow> \<bar>f x k - f y k\<bar> \<le> d;
      f \<in> Poly_Mapping.keys(simplicial_subdivision p c);
      x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk>
     \<Longrightarrow> \<bar>f x k - f y k\<bar> \<le> (p / (Suc p)) * d"
 proof (induction p arbitrary: d c f x y)
   case (Suc p)
   define Sigp where "Sigp \<equiv> \<lambda>f:: (nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> real. \<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / real (p + 2)"
   let ?CB = "\<lambda>f. chain_boundary (Suc p) (frag_of f)"
   have *: "Poly_Mapping.keys
              (simplicial_cone p (Sigp f)
                (simplicial_subdivision p (?CB f)))
            \<subseteq> {f. \<forall>x\<in>standard_simplex (Suc p). \<forall>y\<in>standard_simplex (Suc p).
                       \<bar>f x k - f y k\<bar> \<le> real (Suc p) / (real p + 2) * d}" (is "?lhs \<subseteq> ?rhs")
     if f: "f \<in> Poly_Mapping.keys c" for f
   proof -
     have ssf: "simplicial_simplex (Suc p) S f"
       using Suc.prems(1) simplicial_chain_def that by auto
     have 2: "\<And>x y. \<lbrakk>x \<in> standard_simplex (Suc p); y \<in> standard_simplex (Suc p)\<rbrakk> \<Longrightarrow> \<bar>f x k - f y k\<bar> \<le> d"
       by (meson Suc.prems(2) f subsetD le_Suc_eq order_refl standard_simplex_mono)
     have sub: "Poly_Mapping.keys ((frag_of \<circ> simplex_cone p (Sigp f)) g) \<subseteq> ?rhs"
       if "g \<in> Poly_Mapping.keys (simplicial_subdivision p (?CB f))" for g
     proof -
       have 1: "simplicial_chain p S (?CB f)"
         using ssf simplicial_chain_boundary simplicial_chain_of by fastforce
       have "simplicial_chain (Suc p) (f ` standard_simplex(Suc p)) (frag_of f)"
         by (metis simplicial_chain_of simplicial_simplex ssf subset_refl)
       then have sc_sub: "Poly_Mapping.keys (?CB f)
                          \<subseteq> Collect (simplicial_simplex p (f ` standard_simplex (Suc p)))"
         by (metis diff_Suc_1 simplicial_chain_boundary simplicial_chain_def)
       have led: "\<And>h x y. \<lbrakk>h \<in> Poly_Mapping.keys (chain_boundary (Suc p) (frag_of f));
                           x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk> \<Longrightarrow> \<bar>h x k - h y k\<bar> \<le> d"
         using Suc.prems(2) f sc_sub
         by (simp add: simplicial_simplex subset_iff image_iff) metis
       have "\<And>f' x y. \<lbrakk>f' \<in> Poly_Mapping.keys (simplicial_subdivision p (?CB f)); x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk>
             \<Longrightarrow> \<bar>f' x k - f' y k\<bar> \<le> (p / (Suc p)) * d"
         by (blast intro: led Suc.IH [of "chain_boundary (Suc p) (frag_of f)", OF 1])
       then have g: "\<And>x y. \<lbrakk>x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk> \<Longrightarrow> \<bar>g x k - g y k\<bar> \<le> (p / (Suc p)) * d"
         using that by blast
       have "d \<ge> 0"
         using Suc.prems(2)[OF f] \<open>x \<in> standard_simplex (Suc p)\<close> by force
       have 3: "simplex_cone p (Sigp f) g \<in> ?rhs"
       proof -
         have "simplicial_simplex p (f ` standard_simplex(Suc p)) g"
           by (metis (mono_tags, hide_lams) sc_sub mem_Collect_eq simplicial_chain_def simplicial_chain_simplicial_subdivision subsetD that)
         then obtain m where m: "g ` standard_simplex p \<subseteq> f ` standard_simplex (Suc p)"
           and geq: "g = oriented_simplex p m"
           using ssf by (auto simp: simplicial_simplex)
         have m_in_gim: "m i \<in> g ` standard_simplex p" if "i \<le> p" for i
         proof 
           show "m i = g (\<lambda>j. if j = i then 1 else 0)"
             by (simp add: geq oriented_simplex_def that if_distrib cong: if_cong)
           show "(\<lambda>j. if j = i then 1 else 0) \<in> standard_simplex p"
             by (simp add: oriented_simplex_def that)
         qed
         obtain l where l: "f ` standard_simplex (Suc p) \<subseteq> S"
           and feq: "f = oriented_simplex (Suc p) l"
           using ssf by (auto simp: simplicial_simplex)
         show ?thesis
         proof (clarsimp simp add: geq simp del: sum.atMost_Suc)
           fix x y
           assume x: "x \<in> standard_simplex (Suc p)" and y: "y \<in> standard_simplex (Suc p)"
           then have x': "(\<forall>i. 0 \<le> x i \<and> x i \<le> 1) \<and> (\<forall>i>Suc p. x i = 0) \<and> (\<Sum>i\<le>Suc p. x i) = 1"
             and y': "(\<forall>i. 0 \<le> y i \<and> y i \<le> 1) \<and> (\<forall>i>Suc p. y i = 0) \<and> (\<Sum>i\<le>Suc p. y i) = 1"
             by (auto simp: standard_simplex_def)
           have "\<bar>(\<Sum>j\<le>Suc p. (if j = 0 then \<lambda>i. (\<Sum>j\<le>Suc p. l j i) / (2 + real p) else m (j -1)) k * x j) -
                  (\<Sum>j\<le>Suc p. (if j = 0 then \<lambda>i. (\<Sum>j\<le>Suc p. l j i) / (2 + real p) else m (j -1)) k * y j)\<bar>
                 \<le> (1 + real p) * d / (2 + real p)"
           proof -
             have zero: "\<bar>m (s - Suc 0) k - (\<Sum>j\<le>Suc p. l j k) / (2 + real p)\<bar> \<le> (1 + real p) * d / (2 + real p)"
               if "0 < s" and "s \<le> Suc p" for s
             proof -
               have "m (s - Suc 0) \<in> f ` standard_simplex (Suc p)"
                 using m m_in_gim that(2) by auto
               then obtain z where eq: "m (s - Suc 0) = (\<lambda>i. \<Sum>j\<le>Suc p. l j i * z j)" and z: "z \<in> standard_simplex (Suc p)"
                 using feq unfolding oriented_simplex_def by auto
               show ?thesis
                 unfolding eq
               proof (rule convex_sum_bound_le)
                 fix i
                 assume i: "i \<in> {..Suc p}"
                 then have [simp]: "card ({..Suc p} - {i}) = Suc p"
                   by (simp add: card_Suc_Diff1)
                 have "(\<Sum>j\<le>Suc p. \<bar>l i k / (p + 2) - l j k / (p + 2)\<bar>) = (\<Sum>j\<le>Suc p. \<bar>l i k - l j k\<bar> / (p + 2))"
                   by (rule sum.cong) (simp_all add: flip: diff_divide_distrib)
                 also have "\<dots> = (\<Sum>j \<in> {..Suc p} - {i}. \<bar>l i k - l j k\<bar> / (p + 2))"
                   by (rule sum.mono_neutral_right) auto
                 also have "\<dots> \<le> (1 + real p) * d / (p + 2)"
                 proof (rule sum_bounded_above_divide)
                   fix i' :: "nat"
                   assume i': "i' \<in> {..Suc p} - {i}"
                   have lf: "l r \<in> f ` standard_simplex(Suc p)" if "r \<le> Suc p" for r
                   proof
                     show "l r = f (\<lambda>j. if j = r then 1 else 0)"
                       using that by (simp add: feq oriented_simplex_def if_distrib cong: if_cong)
                     show "(\<lambda>j. if j = r then 1 else 0) \<in> standard_simplex (Suc p)"
                       by (auto simp: oriented_simplex_def that)
                   qed
                   show "\<bar>l i k - l i' k\<bar> / real (p + 2) \<le> (1 + real p) * d / real (p + 2) / real (card ({..Suc p} - {i}))"
                     using i i' lf [of i] lf [of i'] 2
                     by (auto simp: image_iff divide_simps)
                 qed auto
                 finally have "(\<Sum>j\<le>Suc p. \<bar>l i k / (p + 2) - l j k / (p + 2)\<bar>) \<le> (1 + real p) * d / (p + 2)" .
                 then have "\<bar>\<Sum>j\<le>Suc p. l i k / (p + 2) - l j k / (p + 2)\<bar> \<le> (1 + real p) * d / (p + 2)"
                   by (rule order_trans [OF sum_abs])
                 then show "\<bar>l i k - (\<Sum>j\<le>Suc p. l j k) / (2 + real p)\<bar> \<le> (1 + real p) * d / (2 + real p)"
                   by (simp add: sum_subtractf sum_divide_distrib del: sum.atMost_Suc)
               qed (use standard_simplex_def z in auto)
             qed
             have nonz: "\<bar>m (s - Suc 0) k - m (r - Suc 0) k\<bar> \<le> (1 + real p) * d / (2 + real p)" (is "?lhs \<le> ?rhs")
               if "r < s" and "0 < r" and "r \<le> Suc p" and "s \<le> Suc p" for r s
             proof -
               have "?lhs \<le> (p / (Suc p)) * d"
                 using m_in_gim [of "r - Suc 0"] m_in_gim [of "s - Suc 0"] that g by fastforce
               also have "\<dots> \<le> ?rhs"
                 by (simp add: field_simps \<open>0 \<le> d\<close>)
               finally show ?thesis .
             qed
             have jj: "j \<le> Suc p \<and> j' \<le> Suc p
                 \<longrightarrow> \<bar>(if j' = 0 then \<lambda>i. (\<Sum>j\<le>Suc p. l j i) / (2 + real p) else m (j' -1)) k -
                      (if j = 0 then \<lambda>i. (\<Sum>j\<le>Suc p. l j i) / (2 + real p) else m (j -1)) k\<bar>
                      \<le> (1 + real p) * d / (2 + real p)" for j j'
               using \<open>0 \<le> d\<close> 
               by (rule_tac a=j and b = "j'" in linorder_less_wlog; force simp: zero nonz simp del: sum.atMost_Suc)
             show ?thesis
               apply (rule convex_sum_bound_le)
               using x' apply blast
               using x' apply blast
               apply (subst abs_minus_commute)
               apply (rule convex_sum_bound_le)
               using y' apply blast
               using y' apply blast
               using jj by blast
           qed
           then show "\<bar>simplex_cone p (Sigp f) (oriented_simplex p m) x k - simplex_cone p (Sigp f) (oriented_simplex p m) y k\<bar>
                 \<le> (1 + real p) * d / (real p + 2)"
             apply (simp add: feq Sigp_def simplicial_vertex_oriented_simplex simplex_cone del: sum.atMost_Suc)
             apply (simp add: oriented_simplex_def algebra_simps x y del: sum.atMost_Suc)
             done
         qed
       qed
       show ?thesis
         using Suc.IH [OF 1, where f=g] 2 3 by simp
     qed
     then show ?thesis
       unfolding simplicial_chain_def simplicial_cone_def
       by (simp add: order_trans [OF keys_frag_extend] sub UN_subset_iff)
   qed
   show ?case
     using Suc
     apply (simp del: sum.atMost_Suc)
     apply (drule subsetD [OF keys_frag_extend])
     apply (simp del: sum.atMost_Suc)
     apply clarify (*OBTAIN?*)
     apply (rename_tac FFF)
     using *
     apply (simp add: add.commute Sigp_def subset_iff)
     done
 qed (auto simp: standard_simplex_0)
 
 
 subsection\<open>Singular subdivision\<close>
 
 definition singular_subdivision
   where "singular_subdivision p \<equiv>
         frag_extend
            (\<lambda>f. chain_map p f
                   (simplicial_subdivision p
                          (frag_of(restrict id (standard_simplex p)))))"
 
 lemma singular_subdivision_0 [simp]: "singular_subdivision p 0 = 0"
   by (simp add: singular_subdivision_def)
 
 lemma singular_subdivision_add:
    "singular_subdivision p (a + b) = singular_subdivision p a + singular_subdivision p b"
   by (simp add: singular_subdivision_def frag_extend_add)
 
 lemma singular_subdivision_diff:
    "singular_subdivision p (a - b) = singular_subdivision p a - singular_subdivision p b"
   by (simp add: singular_subdivision_def frag_extend_diff)
 
 lemma simplicial_simplex_id [simp]:
    "simplicial_simplex p S (restrict id (standard_simplex p)) \<longleftrightarrow> standard_simplex p \<subseteq> S"
     (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then show ?rhs
     by (simp add: simplicial_simplex_def singular_simplex_def continuous_map_in_subtopology set_mp)
 next
   assume R: ?rhs
   then have cm: "continuous_map
                  (subtopology (powertop_real UNIV) (standard_simplex p))
                  (subtopology (powertop_real UNIV) S) id"
     using continuous_map_from_subtopology_mono continuous_map_id by blast
   moreover have "\<exists>l. restrict id (standard_simplex p) = oriented_simplex p l"
     apply (rule_tac x="\<lambda>i j. if i = j then 1 else 0" in exI)
     apply (force simp: oriented_simplex_def standard_simplex_def if_distrib [of "\<lambda>u. u * _"] cong: if_cong)
     done
   ultimately show ?lhs
     by (simp add: simplicial_simplex_def singular_simplex_def)
 qed
 
 lemma singular_chain_singular_subdivision:
    "singular_chain p X c
         \<Longrightarrow> singular_chain p X (singular_subdivision p c)"
   unfolding singular_subdivision_def
   apply (rule singular_chain_extend)
   apply (rule singular_chain_chain_map [where X = "subtopology (powertop_real UNIV)
                           (standard_simplex p)"])
   apply (simp add: simplicial_chain_simplicial_subdivision simplicial_imp_singular_chain)
   by (simp add: singular_chain_def singular_simplex_def subset_iff)
 
 lemma naturality_singular_subdivision:
    "singular_chain p X c
     \<Longrightarrow> singular_subdivision p (chain_map p g c) = chain_map p g (singular_subdivision p c)"
   unfolding singular_chain_def
 proof (induction rule: frag_induction)
   case (one f)
   then have "singular_simplex p X f"
     by auto
   have "\<lbrakk>simplicial_chain p (standard_simplex p) d\<rbrakk>
     \<Longrightarrow> chain_map p (simplex_map p g f) d = chain_map p g (chain_map p f d)" for d
     unfolding simplicial_chain_def
   proof (induction rule: frag_induction)
     case (one x)
     then have "simplex_map p (simplex_map p g f) x = simplex_map p g (simplex_map p f x)"
       by (force simp: simplex_map_def restrict_compose_left simplicial_simplex)
     then show ?case
       by auto
   qed (auto simp: chain_map_diff)
   then show ?case
     using simplicial_chain_simplicial_subdivision [of p "standard_simplex p" "frag_of (restrict id (standard_simplex p))"]
     by (simp add: singular_subdivision_def)
 next
   case (diff a b)
   then show ?case
     by (simp add: chain_map_diff singular_subdivision_diff)
 qed auto
 
 lemma simplicial_chain_chain_map:
   assumes f: "simplicial_simplex q X f" and c: "simplicial_chain p (standard_simplex q) c"
   shows "simplicial_chain p X (chain_map p f c)"
   using c unfolding simplicial_chain_def
 proof (induction c rule: frag_induction)
   case (one g)
   have "\<exists>n. simplex_map p (oriented_simplex q l)
                  (oriented_simplex p m) = oriented_simplex p n"
     if m: "singular_simplex p
                 (subtopology (powertop_real UNIV) (standard_simplex q)) (oriented_simplex p m)"
     for l m
   proof -
     have "(\<lambda>i. \<Sum>j\<le>p. m j i * x j) \<in> standard_simplex q"
       if "x \<in> standard_simplex p" for x
       using that m unfolding oriented_simplex_def singular_simplex_def
       by (auto simp: continuous_map_in_subtopology image_subset_iff)
     then show ?thesis
       unfolding oriented_simplex_def simplex_map_def
       apply (rule_tac x="\<lambda>j k. (\<Sum>i\<le>q. l i k * m j i)" in exI)
       apply (force simp: sum_distrib_left sum_distrib_right mult.assoc intro: sum.swap)
       done
   qed
   then show ?case
     using f one
     apply (auto simp: simplicial_simplex_def)
     apply (rule singular_simplex_simplex_map
         [where X = "subtopology (powertop_real UNIV) (standard_simplex q)"])
     unfolding singular_simplex_def apply (fastforce simp add:)+
     done
 next
   case (diff a b)
   then show ?case
     by (metis chain_map_diff simplicial_chain_def simplicial_chain_diff)
 qed auto
 
 
 lemma singular_subdivision_simplicial_simplex:
    "simplicial_chain p S c
            \<Longrightarrow> singular_subdivision p c = simplicial_subdivision p c"
 proof (induction p arbitrary: S c)
   case 0
   then show ?case
     unfolding simplicial_chain_def
   proof (induction rule: frag_induction)
     case (one x)
     then show ?case
       using singular_simplex_chain_map_id simplicial_imp_singular_simplex
       by (fastforce simp: singular_subdivision_def simplicial_subdivision_def)
   qed (auto simp: singular_subdivision_diff)
 next
   case (Suc p)
   show ?case
     using Suc.prems unfolding simplicial_chain_def
   proof (induction rule: frag_induction)
     case (one f)
     then have ssf: "simplicial_simplex (Suc p) S f"
       by (auto simp: simplicial_simplex)
     then have 1: "simplicial_chain p (standard_simplex (Suc p))
                    (simplicial_subdivision p
                      (chain_boundary (Suc p)
                        (frag_of (restrict id (standard_simplex (Suc p))))))"
       by (metis diff_Suc_1 order_refl simplicial_chain_boundary simplicial_chain_of simplicial_chain_simplicial_subdivision simplicial_simplex_id)
     have 2: "(\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j (restrict id (standard_simplex (Suc p))) i) / (real p + 2))
                   \<in> standard_simplex (Suc p)"
       by (simp add: simplicial_vertex_def standard_simplex_def del: sum.atMost_Suc)
     have ss_Sp: "(\<lambda>i. (if i \<le> Suc p then 1 else 0) / (real p + 2)) \<in> standard_simplex (Suc p)"
       by (simp add: standard_simplex_def field_split_simps)
     obtain l where feq: "f = oriented_simplex (Suc p) l"
       using one unfolding simplicial_simplex by blast
     then have 3: "f (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j (restrict id (standard_simplex (Suc p))) i) / (real p + 2))
                 = (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (real p + 2))"
       unfolding simplicial_vertex_def oriented_simplex_def
       by (simp add: ss_Sp if_distrib [of "\<lambda>x. _ * x"] sum_divide_distrib del: sum.atMost_Suc cong: if_cong)
     have scp: "singular_chain (Suc p)
                  (subtopology (powertop_real UNIV) (standard_simplex (Suc p)))
                  (frag_of (restrict id (standard_simplex (Suc p))))"
       by (simp add: simplicial_imp_singular_chain)
     have scps: "simplicial_chain p (standard_simplex (Suc p))
                   (chain_boundary (Suc p) (frag_of (restrict id (standard_simplex (Suc p)))))"
       by (metis diff_Suc_1 order_refl simplicial_chain_boundary simplicial_chain_of simplicial_simplex_id)
     have scpf: "simplicial_chain p S
                  (chain_map p f
                    (chain_boundary (Suc p) (frag_of (restrict id (standard_simplex (Suc p))))))"
       using scps simplicial_chain_chain_map ssf by blast
     have 4: "chain_map p f
                 (simplicial_subdivision p
                    (chain_boundary (Suc p) (frag_of (restrict id (standard_simplex (Suc p))))))
            = simplicial_subdivision p (chain_boundary (Suc p) (frag_of f))"
       apply (simp add: chain_boundary_chain_map [OF scp] del: chain_map_of
           flip: singular_simplex_chain_map_id [OF simplicial_imp_singular_simplex [OF ssf]])
       by (metis (no_types) scp singular_chain_boundary_alt Suc.IH [OF scps] Suc.IH [OF scpf] naturality_singular_subdivision)
     show ?case
       apply (simp add: singular_subdivision_def del: sum.atMost_Suc)
       apply (simp only: ssf 1 2 3 4 chain_map_simplicial_cone [of "Suc p" S _ p "Suc p"])
       done
   qed (auto simp: frag_extend_diff singular_subdivision_diff)
 qed
 
 
 lemma naturality_simplicial_subdivision:
    "\<lbrakk>simplicial_chain p (standard_simplex q) c; simplicial_simplex q S g\<rbrakk>
     \<Longrightarrow> simplicial_subdivision p (chain_map p g c) = chain_map p g (simplicial_subdivision p c)"
 apply (simp flip: singular_subdivision_simplicial_simplex)
   by (metis naturality_singular_subdivision simplicial_chain_chain_map simplicial_imp_singular_chain singular_subdivision_simplicial_simplex)
 
 lemma chain_boundary_singular_subdivision:
    "singular_chain p X c
         \<Longrightarrow> chain_boundary p (singular_subdivision p c) =
             singular_subdivision (p - Suc 0) (chain_boundary p c)"
   unfolding singular_chain_def
 proof (induction rule: frag_induction)
   case (one f)
     then have ssf: "singular_simplex p X f"
       by (auto simp: singular_simplex_def)
     then have scp: "simplicial_chain p (standard_simplex p) (frag_of (restrict id (standard_simplex p)))"
       by simp
     have scp1: "simplicial_chain (p - Suc 0) (standard_simplex p)
                   (chain_boundary p (frag_of (restrict id (standard_simplex p))))"
       using simplicial_chain_boundary by force
     have sgp1: "singular_chain (p - Suc 0)
                    (subtopology (powertop_real UNIV) (standard_simplex p))
                    (chain_boundary p (frag_of (restrict id (standard_simplex p))))"
       using scp1 simplicial_imp_singular_chain by blast
     have scpp: "singular_chain p (subtopology (powertop_real UNIV) (standard_simplex p))
                   (frag_of (restrict id (standard_simplex p)))"
       using scp simplicial_imp_singular_chain by blast
     then show ?case
       unfolding singular_subdivision_def
       using chain_boundary_chain_map [of p "subtopology (powertop_real UNIV)
                               (standard_simplex p)" _ f]
       apply (simp add: simplicial_chain_simplicial_subdivision
           simplicial_imp_singular_chain chain_boundary_simplicial_subdivision [OF scp]
           flip: singular_subdivision_simplicial_simplex [OF scp1] naturality_singular_subdivision [OF sgp1])
       by (metis (full_types)   singular_subdivision_def  chain_boundary_chain_map [OF scpp] singular_simplex_chain_map_id [OF ssf])
 qed (auto simp: singular_subdivision_def frag_extend_diff chain_boundary_diff)
 
 lemma singular_subdivision_zero:
   "singular_chain 0 X c \<Longrightarrow> singular_subdivision 0 c = c"
   unfolding singular_chain_def
 proof (induction rule: frag_induction)
   case (one f)
   then have "restrict (f \<circ> restrict id (standard_simplex 0)) (standard_simplex 0) = f"
     by (simp add: extensional_restrict restrict_compose_right singular_simplex_def)
   then show ?case
     by (auto simp: singular_subdivision_def simplex_map_def)
 qed (auto simp: singular_subdivision_def frag_extend_diff)
 
 
 primrec subd where
   "subd 0 = (\<lambda>x. 0)"
 | "subd (Suc p) =
       frag_extend
        (\<lambda>f. simplicial_cone (Suc p) (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / real (Suc p + 1))
                (simplicial_subdivision (Suc p) (frag_of f) - frag_of f -
                 subd p (chain_boundary (Suc p) (frag_of f))))"
 
 lemma subd_0 [simp]: "subd p 0 = 0"
   by (induction p) auto
 
 lemma subd_diff [simp]: "subd p (c1 - c2) = subd p c1 - subd p c2"
   by (induction p) (auto simp: frag_extend_diff)
 
 lemma subd_uminus [simp]: "subd p (-c) = - subd p c"
   by (metis diff_0 subd_0 subd_diff)
 
 lemma subd_power_uminus: "subd p (frag_cmul ((-1) ^ k) c) = frag_cmul ((-1) ^ k) (subd p c)"
   apply (induction k, simp_all)
   by (metis minus_frag_cmul subd_uminus)
 
 lemma subd_power_sum: "subd p (sum f I) = sum (subd p \<circ> f) I"
   apply (induction I rule: infinite_finite_induct)
   by auto (metis add_diff_cancel_left' diff_add_cancel subd_diff)
 
 lemma subd: "simplicial_chain p (standard_simplex s) c
      \<Longrightarrow> (\<forall>r g. simplicial_simplex s (standard_simplex r) g \<longrightarrow> chain_map (Suc p) g (subd p c) = subd p (chain_map p g c))
          \<and> simplicial_chain (Suc p) (standard_simplex s) (subd p c)
          \<and> (chain_boundary (Suc p) (subd p c)) + (subd (p - Suc 0) (chain_boundary p c)) = (simplicial_subdivision p c) - c"
 proof (induction p arbitrary: c)
   case (Suc p)
   show ?case
     using Suc.prems [unfolded simplicial_chain_def]
   proof (induction rule: frag_induction)
     case (one f)
     then obtain l where l: "(\<lambda>x i. \<Sum>j\<le>Suc p. l j i * x j) ` standard_simplex (Suc p) \<subseteq> standard_simplex s"
                   and feq: "f = oriented_simplex (Suc p) l"
       by (metis (mono_tags) mem_Collect_eq simplicial_simplex simplicial_simplex_oriented_simplex)
     have scf: "simplicial_chain (Suc p) (standard_simplex s) (frag_of f)"
       using one by simp
     have lss: "l i \<in> standard_simplex s" if "i \<le> Suc p" for i
     proof -
       have "(\<lambda>i'. \<Sum>j\<le>Suc p. l j i' * (if j = i then 1 else 0)) \<in> standard_simplex s"
         using subsetD [OF l] basis_in_standard_simplex that by blast
       moreover have "(\<lambda>i'. \<Sum>j\<le>Suc p. l j i' * (if j = i then 1 else 0)) = l i"
         using that by (simp add: if_distrib [of "\<lambda>x. _ * x"] del: sum.atMost_Suc cong: if_cong)
       ultimately show ?thesis
         by simp
     qed
     have *: "(\<And>i. i \<le> n \<Longrightarrow> l i \<in> standard_simplex s)
      \<Longrightarrow> (\<lambda>i. (\<Sum>j\<le>n. l j i) / (Suc n)) \<in> standard_simplex s" for n
     proof (induction n)
       case (Suc n)
       let ?x = "\<lambda>i. (1 - inverse (n + 2)) * ((\<Sum>j\<le>n. l j i) / (Suc n)) + inverse (n + 2) * l (Suc n) i"
       have "?x \<in> standard_simplex s"
       proof (rule convex_standard_simplex)
         show "(\<lambda>i. (\<Sum>j\<le>n. l j i) / real (Suc n)) \<in> standard_simplex s"
           using Suc by simp
       qed (auto simp: lss Suc inverse_le_1_iff)
       moreover have "?x = (\<lambda>i. (\<Sum>j\<le>Suc n. l j i) / real (Suc (Suc n)))"
         by (force simp: divide_simps)
       ultimately show ?case
         by simp
     qed auto
     have **: "(\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (2 + real p)) \<in> standard_simplex s"
       using * [of "Suc p"] lss by (simp add: simplicial_vertex_oriented_simplex feq)
     show ?case
     proof (intro conjI impI allI)
       fix r g
       assume g: "simplicial_simplex s (standard_simplex r) g"
       then obtain m where geq: "g = oriented_simplex s m"
         using simplicial_simplex by blast
       have 1: "simplicial_chain (Suc p) (standard_simplex s) (simplicial_subdivision (Suc p) (frag_of f))"
         by (metis mem_Collect_eq one.hyps simplicial_chain_of simplicial_chain_simplicial_subdivision)
       have 2: "(\<Sum>j\<le>Suc p. \<Sum>i\<le>s. m i k * simplicial_vertex j f i)
              = (\<Sum>j\<le>Suc p. simplicial_vertex j
                                 (simplex_map (Suc p) (oriented_simplex s m) f) k)" for k
       proof (rule sum.cong [OF refl])
         fix j
         assume j: "j \<in> {..Suc p}"
         have eq: "simplex_map (Suc p) (oriented_simplex s m) (oriented_simplex (Suc p) l)
                 = oriented_simplex (Suc p) (oriented_simplex s m \<circ> l)"
         proof (rule simplex_map_oriented_simplex)
           show "simplicial_simplex (Suc p) (standard_simplex s) (oriented_simplex (Suc p) l)"
             using one by (simp add: feq flip: oriented_simplex_def)
           show "simplicial_simplex s (standard_simplex r) (oriented_simplex s m)"
             using g by (simp add: geq)
         qed auto
         show "(\<Sum>i\<le>s. m i k * simplicial_vertex j f i)
             = simplicial_vertex j (simplex_map (Suc p) (oriented_simplex s m) f) k"
           using one j
           apply (simp add: feq eq simplicial_vertex_oriented_simplex simplicial_simplex_oriented_simplex image_subset_iff)
           apply (drule_tac x="(\<lambda>i. if i = j then 1 else 0)" in bspec)
            apply (auto simp: oriented_simplex_def lss)
           done
       qed
       have 4: "chain_map (Suc p) g (subd p (chain_boundary (Suc p) (frag_of f)))
              = subd p (chain_boundary (Suc p) (frag_of (simplex_map (Suc p) g f)))"
         by (metis (no_types) One_nat_def scf Suc.IH chain_boundary_chain_map chain_map_of diff_Suc_Suc diff_zero g simplicial_chain_boundary simplicial_imp_singular_chain)
       show "chain_map (Suc (Suc p)) g (subd (Suc p) (frag_of f)) = subd (Suc p) (chain_map (Suc p) g (frag_of f))"
         using g
         apply (simp only: subd.simps frag_extend_of)
         apply (subst chain_map_simplicial_cone [of s "standard_simplex r" _ "Suc p" s], assumption)
            apply (intro simplicial_chain_diff)
         using "1" apply auto[1]
         using one.hyps apply auto[1]
         apply (metis Suc.IH diff_Suc_1 mem_Collect_eq one.hyps simplicial_chain_boundary simplicial_chain_of)
         using "**" apply auto[1]
          apply (rule order_refl)
          apply (simp only: chain_map_of frag_extend_of)
         apply (rule arg_cong2 [where f = "simplicial_cone (Suc p)"])
          apply (simp add: geq sum_distrib_left oriented_simplex_def ** del: sum.atMost_Suc flip: sum_divide_distrib)
         using 2  apply (simp only: oriented_simplex_def sum.swap [where A = "{..s}"])
         using naturality_simplicial_subdivision scf apply (fastforce simp add: 4 chain_map_diff)
         done
     next
       have sc: "simplicial_chain (Suc p) (standard_simplex s)
                (simplicial_cone p
                  (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (Suc (Suc p)))
                  (simplicial_subdivision p
                    (chain_boundary (Suc p) (frag_of f))))"
           by (metis diff_Suc_1 nat.simps(3) simplicial_subdivision_of scf simplicial_chain_simplicial_subdivision)
       have ff: "simplicial_chain (Suc p) (standard_simplex s) (subd p (chain_boundary (Suc p) (frag_of f)))"
         by (metis (no_types) Suc.IH diff_Suc_1 scf simplicial_chain_boundary)
       show "simplicial_chain (Suc (Suc p)) (standard_simplex s) (subd (Suc p) (frag_of f))"
         using one
         apply (simp only: subd.simps frag_extend_of)
         apply (rule_tac S="standard_simplex s" in simplicial_chain_simplicial_cone)
          apply (intro simplicial_chain_diff ff)
         using sc apply (simp add: algebra_simps)
         using "**" convex_standard_simplex  apply force+
         done
       have "simplicial_chain p (standard_simplex s) (chain_boundary (Suc p) (frag_of f))"
         using scf simplicial_chain_boundary by fastforce
       then have "chain_boundary (Suc p) (simplicial_subdivision (Suc p) (frag_of f) - frag_of f
                                          - subd p (chain_boundary (Suc p) (frag_of f))) = 0"
         apply (simp only: chain_boundary_diff)
         using Suc.IH chain_boundary_boundary [of "Suc p" "subtopology (powertop_real UNIV)
                                 (standard_simplex s)" "frag_of f"]
         by (metis One_nat_def add_diff_cancel_left' subd_0 chain_boundary_simplicial_subdivision plus_1_eq_Suc scf simplicial_imp_singular_chain)
       then show "chain_boundary (Suc (Suc p)) (subd (Suc p) (frag_of f))
           + subd (Suc p - Suc 0) (chain_boundary (Suc p) (frag_of f))
           = simplicial_subdivision (Suc p) (frag_of f) - frag_of f"
         apply (simp only: subd.simps frag_extend_of)
         apply (subst chain_boundary_simplicial_cone [of "Suc p" "standard_simplex s"])
          apply (meson ff scf simplicial_chain_diff simplicial_chain_simplicial_subdivision)
         apply (simp add: simplicial_cone_def del: sum.atMost_Suc simplicial_subdivision.simps)
         done
     qed
   next
     case (diff a b)
     then show ?case
       apply safe
         apply (metis chain_map_diff subd_diff)
        apply (metis simplicial_chain_diff subd_diff)
       apply (auto simp:  simplicial_subdivision_diff chain_boundary_diff
           simp del: simplicial_subdivision.simps subd.simps)
       by (metis (no_types, lifting) add_diff_add add_uminus_conv_diff diff_0 diff_diff_add)
   qed auto
 qed simp
 
 lemma chain_homotopic_simplicial_subdivision1:
   "\<lbrakk>simplicial_chain p (standard_simplex q) c; simplicial_simplex q (standard_simplex r) g\<rbrakk>
        \<Longrightarrow> chain_map (Suc p) g (subd p c) = subd p (chain_map p g c)"
   by (simp add: subd)
 
 lemma chain_homotopic_simplicial_subdivision2:
   "simplicial_chain p (standard_simplex q) c
        \<Longrightarrow> simplicial_chain (Suc p) (standard_simplex q) (subd p c)"
   by (simp add: subd)
 
 lemma chain_homotopic_simplicial_subdivision3:
   "simplicial_chain p (standard_simplex q) c
    \<Longrightarrow> chain_boundary (Suc p) (subd p c) = (simplicial_subdivision p c) - c - subd (p - Suc 0) (chain_boundary p c)"
   by (simp add: subd algebra_simps)
 
 lemma chain_homotopic_simplicial_subdivision:
   "\<exists>h. (\<forall>p. h p 0 = 0) \<and>
        (\<forall>p c1 c2. h p (c1-c2) = h p c1 - h p c2) \<and>
        (\<forall>p q r g c.
                 simplicial_chain p (standard_simplex q) c
                 \<longrightarrow> simplicial_simplex q (standard_simplex r) g
                 \<longrightarrow> chain_map (Suc p) g (h p c) = h p (chain_map p g c)) \<and>
        (\<forall>p q c. simplicial_chain p (standard_simplex q) c
                 \<longrightarrow> simplicial_chain (Suc p) (standard_simplex q) (h p c)) \<and>
        (\<forall>p q c. simplicial_chain p (standard_simplex q) c
                 \<longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c)
                   = (simplicial_subdivision p c) - c)"
   by (rule_tac x=subd in exI) (fastforce simp: subd)
 
 lemma chain_homotopic_singular_subdivision:
   obtains h where
         "\<And>p. h p 0 = 0"
         "\<And>p c1 c2. h p (c1-c2) = h p c1 - h p c2"
         "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (h p c)"
         "\<And>p X c. singular_chain p X c
                  \<Longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c) = singular_subdivision p c - c"
 proof -
   define k where "k \<equiv> \<lambda>p. frag_extend (\<lambda>f:: (nat \<Rightarrow> real) \<Rightarrow> 'a. chain_map (Suc p) f (subd p (frag_of(restrict id (standard_simplex p)))))"
   show ?thesis
   proof
     fix p X and c :: "'a chain"
     assume c: "singular_chain p X c"
     have "singular_chain (Suc p) X (k p c) \<and>
                chain_boundary (Suc p) (k p c) + k (p - Suc 0) (chain_boundary p c) = singular_subdivision p c - c"
       using c [unfolded singular_chain_def]
     proof (induction rule: frag_induction)
       case (one f)
       let ?X = "subtopology (powertop_real UNIV) (standard_simplex p)"
       show ?case
       proof (simp add: k_def, intro conjI)
         show "singular_chain (Suc p) X (chain_map (Suc p) f (subd p (frag_of (restrict id (standard_simplex p)))))"
         proof (rule singular_chain_chain_map)
           show "singular_chain (Suc p) ?X  (subd p (frag_of (restrict id (standard_simplex p))))"
             by (simp add: chain_homotopic_simplicial_subdivision2 simplicial_imp_singular_chain)
           show "continuous_map ?X X f"
             using one.hyps singular_simplex_def by auto
         qed
       next
         have scp: "singular_chain (Suc p) ?X (subd p (frag_of (restrict id (standard_simplex p))))"
           by (simp add: chain_homotopic_simplicial_subdivision2 simplicial_imp_singular_chain)
         have feqf: "frag_of (simplex_map p f (restrict id (standard_simplex p))) = frag_of f"
           using one.hyps singular_simplex_chain_map_id by auto
         have *: "chain_map p f
                    (subd (p - Suc 0)
                      (\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of (singular_face p k id))))
               = (\<Sum>x\<le>p. frag_cmul ((-1) ^ x)
                          (chain_map p (singular_face p x f)
                            (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0)))))))"
                   (is "?lhs = ?rhs")
                   if "p > 0"
         proof -
           have eqc: "subd (p - Suc 0) (frag_of (singular_face p i id))
                    = chain_map p (singular_face p i id)
                                  (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0)))))"
             if "i \<le> p" for i
           proof -
             have 1: "simplicial_chain (p - Suc 0) (standard_simplex (p - Suc 0))
                        (frag_of (restrict id (standard_simplex (p - Suc 0))))"
               by simp
             have 2: "simplicial_simplex (p - Suc 0) (standard_simplex p) (singular_face p i id)"
               by (metis One_nat_def Suc_leI \<open>0 < p\<close> simplicial_simplex_id simplicial_simplex_singular_face singular_face_restrict subsetI that)
             have 3: "simplex_map (p - Suc 0) (singular_face p i id) (restrict id (standard_simplex (p - Suc 0)))
                    = singular_face p i id"
               by (force simp: simplex_map_def singular_face_def)
             show ?thesis
               using chain_homotopic_simplicial_subdivision1 [OF 1 2]
                 that \<open>p > 0\<close>  by (simp add: 3)
           qed
           have xx: "simplicial_chain p (standard_simplex(p - Suc 0))
                     (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0)))))"
             by (metis Suc_pred chain_homotopic_simplicial_subdivision2 order_refl simplicial_chain_of simplicial_simplex_id that)
           have yy: "\<And>k. k \<le> p \<Longrightarrow>
                  chain_map p f
                   (chain_map p (singular_face p k id) h) = chain_map p (singular_face p k f) h"
             if "simplicial_chain p (standard_simplex(p - Suc 0)) h" for h
             using that unfolding simplicial_chain_def
           proof (induction h rule: frag_induction)
             case (one x)
             then show ?case
                 using one
               apply (simp add: chain_map_of singular_simplex_def simplicial_simplex_def, auto)
                 apply (rule_tac f=frag_of in arg_cong, rule)
                 apply (simp add: simplex_map_def)
                 by (simp add: continuous_map_in_subtopology image_subset_iff singular_face_def)
           qed (auto simp: chain_map_diff)
           have "?lhs
                 = chain_map p f
                       (\<Sum>k\<le>p. frag_cmul ((-1) ^ k)
                           (chain_map p (singular_face p k id)
                            (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0)))))))"
             by (simp add: subd_power_sum subd_power_uminus eqc)
           also have "\<dots> = ?rhs"
             by (simp add: chain_map_sum xx yy)
           finally show ?thesis .
       qed
         have "chain_map p f
                    (simplicial_subdivision p (frag_of (restrict id (standard_simplex p)))
                    - subd (p - Suc 0) (chain_boundary p (frag_of (restrict id (standard_simplex p)))))
               = singular_subdivision p (frag_of f)
               - frag_extend
                    (\<lambda>f. chain_map (Suc (p - Suc 0)) f
                          (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0))))))
                    (chain_boundary p (frag_of f))"
           apply (simp add: singular_subdivision_def chain_map_diff)
           apply (clarsimp simp add: chain_boundary_def)
           apply (simp add: frag_extend_sum frag_extend_cmul *)
           done
         then show "chain_boundary (Suc p) (chain_map (Suc p) f (subd p (frag_of (restrict id (standard_simplex p)))))
                  + frag_extend
                    (\<lambda>f. chain_map (Suc (p - Suc 0)) f
                          (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0))))))
                    (chain_boundary p (frag_of f))
                  = singular_subdivision p (frag_of f) - frag_of f"
           by (simp add: chain_boundary_chain_map [OF scp] chain_homotopic_simplicial_subdivision3 [where q=p] chain_map_diff feqf)
       qed
     next
       case (diff a b)
       then show ?case
         apply (simp only: k_def singular_chain_diff chain_boundary_diff frag_extend_diff singular_subdivision_diff)
         by (metis (no_types, lifting) add_diff_add diff_add_cancel)
     qed (auto simp: k_def)
     then show "singular_chain (Suc p) X (k p c)" "chain_boundary (Suc p) (k p c) + k (p - Suc 0) (chain_boundary p c) = singular_subdivision p c - c"
         by auto
   qed (auto simp: k_def frag_extend_diff)
 qed
 
 
 lemma homologous_rel_singular_subdivision:
   assumes "singular_relcycle p X T c"
   shows "homologous_rel p X T (singular_subdivision p c) c"
 proof (cases "p = 0")
   case True
   with assms show ?thesis
     by (auto simp: singular_relcycle_def singular_subdivision_zero)
 next
   case False
   with assms show ?thesis
     unfolding homologous_rel_def singular_relboundary singular_relcycle
     by (metis One_nat_def Suc_diff_1 chain_homotopic_singular_subdivision gr_zeroI)
 qed
 
 
 subsection\<open>Excision argument that we keep doing singular subdivision\<close>
 
 lemma singular_subdivision_power_0 [simp]: "(singular_subdivision p ^^ n) 0 = 0"
   by (induction n) auto
 
 lemma singular_subdivision_power_diff:
   "(singular_subdivision p ^^ n) (a - b) = (singular_subdivision p ^^ n) a - (singular_subdivision p ^^ n) b"
   by (induction n) (auto simp: singular_subdivision_diff)
 
 lemma iterated_singular_subdivision:
    "singular_chain p X c
         \<Longrightarrow> (singular_subdivision p ^^ n) c =
             frag_extend
              (\<lambda>f. chain_map p f
                        ((simplicial_subdivision p ^^ n)
                          (frag_of(restrict id (standard_simplex p))))) c"
 proof (induction n arbitrary: c)
   case 0
   then show ?case
     unfolding singular_chain_def
   proof (induction c rule: frag_induction)
     case (one f)
     then have "restrict f (standard_simplex p) = f"
       by (simp add: extensional_restrict singular_simplex_def)
     then show ?case
       by (auto simp: simplex_map_def cong: restrict_cong)
   qed (auto simp: frag_extend_diff)
 next
   case (Suc n)
   show ?case
     using Suc.prems unfolding singular_chain_def
   proof (induction c rule: frag_induction)
     case (one f)
     then have "singular_simplex p X f"
       by simp
     have scp: "simplicial_chain p (standard_simplex p)
                  ((simplicial_subdivision p ^^ n) (frag_of (restrict id (standard_simplex p))))"
     proof (induction n)
       case 0
       then show ?case
         by (metis funpow_0 order_refl simplicial_chain_of simplicial_simplex_id)
     next
       case (Suc n)
       then show ?case
         by (simp add: simplicial_chain_simplicial_subdivision)
     qed
     have scnp: "simplicial_chain p (standard_simplex p)
                   ((simplicial_subdivision p ^^ n) (frag_of (\<lambda>x\<in>standard_simplex p. x)))"
     proof (induction n)
       case 0
       then show ?case
         by (metis eq_id_iff funpow_0 order_refl simplicial_chain_of simplicial_simplex_id)
     next
       case (Suc n)
       then show ?case
         by (simp add: simplicial_chain_simplicial_subdivision)
     qed
     have sff: "singular_chain p X (frag_of f)"
       by (simp add: \<open>singular_simplex p X f\<close> singular_chain_of)
     then show ?case
       using Suc.IH [OF sff] naturality_singular_subdivision [OF simplicial_imp_singular_chain [OF scp], of f] singular_subdivision_simplicial_simplex [OF scnp]
       by (simp add: singular_chain_of id_def del: restrict_apply)
   qed (auto simp: singular_subdivision_power_diff singular_subdivision_diff frag_extend_diff)
 qed
 
 
 lemma chain_homotopic_iterated_singular_subdivision:
   obtains h where
         "\<And>p. h p 0 = (0 :: 'a chain)"
         "\<And>p c1 c2. h p (c1-c2) = h p c1 - h p c2"
         "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (h p c)"
         "\<And>p X c. singular_chain p X c
                  \<Longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c)
                    = (singular_subdivision p ^^ n) c - c"
 proof (induction n arbitrary: thesis)
   case 0
   show ?case
     by (rule 0 [of "(\<lambda>p x. 0)"]) auto
 next
   case (Suc n)
   then obtain k where k:
         "\<And>p. k p 0 = (0 :: 'a chain)"
         "\<And>p c1 c2. k p (c1-c2) = k p c1 - k p c2"
         "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (k p c)"
         "\<And>p X c. singular_chain p X c
                  \<Longrightarrow> chain_boundary (Suc p) (k p c) + k (p - Suc 0) (chain_boundary p c)
                      = (singular_subdivision p ^^ n) c - c"
     by metis
   obtain h where h:
         "\<And>p. h p 0 = (0 :: 'a chain)"
         "\<And>p c1 c2. h p (c1-c2) = h p c1 - h p c2"
         "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (h p c)"
         "\<And>p X c. singular_chain p X c
                  \<Longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c) = singular_subdivision p c - c"
     by (blast intro: chain_homotopic_singular_subdivision)
   let ?h = "(\<lambda>p c. singular_subdivision (Suc p) (k p c) + h p c)"
   show ?case
   proof (rule Suc.prems)
     fix p X and c :: "'a chain"
     assume "singular_chain p X c"
     then show "singular_chain (Suc p) X (?h p c)"
       by (simp add: h k singular_chain_add singular_chain_singular_subdivision)
   next
     fix p :: "nat" and X :: "'a topology" and c :: "'a chain"
     assume sc: "singular_chain p X c"
     have f5: "chain_boundary (Suc p) (singular_subdivision (Suc p) (k p c)) = singular_subdivision p (chain_boundary (Suc p) (k p c))"
       using chain_boundary_singular_subdivision k(3) sc by fastforce
     have [simp]: "singular_subdivision (Suc (p - Suc 0)) (k (p - Suc 0) (chain_boundary p c)) =
                   singular_subdivision p (k (p - Suc 0) (chain_boundary p c))"
     proof (cases p)
       case 0
       then show ?thesis
         by (simp add: k chain_boundary_def)
     qed auto
     show "chain_boundary (Suc p) (?h p c) + ?h (p - Suc 0) (chain_boundary p c) = (singular_subdivision p ^^ Suc n) c - c"
       using chain_boundary_singular_subdivision [of "Suc p" X]
       apply (simp add: chain_boundary_add f5 h k algebra_simps)
-      by (smt add.assoc add.commute diff_add_cancel h(4) k(4) sc singular_subdivision_add)
+      apply (smt (verit, ccfv_threshold) add.commute add_diff_eq diff_add_cancel diff_diff_eq2 h(4) k(4) sc singular_subdivision_add)
+      done
   qed (auto simp: k h singular_subdivision_diff)
 qed
 
 lemma llemma:
   assumes p: "standard_simplex p \<subseteq> \<Union>\<C>"
       and \<C>: "\<And>U. U \<in> \<C> \<Longrightarrow> openin (powertop_real UNIV) U"
   obtains d where "0 < d"
                   "\<And>K. \<lbrakk>K \<subseteq> standard_simplex p;
                         \<And>x y i. \<lbrakk>i \<le> p; x \<in> K; y \<in> K\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> d\<rbrakk>
                        \<Longrightarrow> \<exists>U. U \<in> \<C> \<and> K \<subseteq> U"
 proof -
   have "\<exists>e U. 0 < e \<and> U \<in> \<C> \<and> x \<in> U \<and>
                 (\<forall>y. (\<forall>i\<le>p. \<bar>y i - x i\<bar> \<le> 2 * e) \<and> (\<forall>i>p. y i = 0) \<longrightarrow> y \<in> U)"
     if x: "x \<in> standard_simplex p" for x
   proof-
     obtain U where U: "U \<in> \<C>" "x \<in> U"
       using x p by blast
     then obtain V where finV: "finite {i. V i \<noteq> UNIV}" and openV: "\<And>i. open (V i)"
                   and xV: "x \<in> Pi\<^sub>E UNIV V" and UV: "Pi\<^sub>E UNIV V \<subseteq> U"
       using \<C> unfolding openin_product_topology_alt by force
     have xVi: "x i \<in> V i" for i
       using PiE_mem [OF xV] by simp
     have "\<And>i. \<exists>e>0. \<forall>x'. \<bar>x' - x i\<bar> < e \<longrightarrow> x' \<in> V i"
       by (rule openV [unfolded open_real, rule_format, OF xVi])
     then obtain d where d: "\<And>i. d i > 0" and dV: "\<And>i x'. \<bar>x' - x i\<bar> < d i \<Longrightarrow> x' \<in> V i"
       by metis
     define e where "e \<equiv> Inf (insert 1 (d ` {i. V i \<noteq> UNIV})) / 3"
     have ed3: "e \<le> d i / 3" if "V i \<noteq> UNIV" for i
       using that finV by (auto simp: e_def intro: cInf_le_finite)
     show "\<exists>e U. 0 < e \<and> U \<in> \<C> \<and> x \<in> U \<and>
                 (\<forall>y. (\<forall>i\<le>p. \<bar>y i - x i\<bar> \<le> 2 * e) \<and> (\<forall>i>p. y i = 0) \<longrightarrow> y \<in> U)"
     proof (intro exI conjI allI impI)
       show "e > 0"
         using d finV by (simp add: e_def finite_less_Inf_iff)
       fix y assume y: "(\<forall>i\<le>p. \<bar>y i - x i\<bar> \<le> 2 * e) \<and> (\<forall>i>p. y i = 0)"
       have "y \<in> Pi\<^sub>E UNIV V"
       proof
         show "y i \<in> V i" for i
         proof (cases "p < i")
           case True
           then show ?thesis
             by (metis (mono_tags, lifting) y x mem_Collect_eq standard_simplex_def xVi)
         next
           case False show ?thesis
           proof (cases "V i = UNIV")
             case False show ?thesis
             proof (rule dV)
               have "\<bar>y i - x i\<bar> \<le> 2 * e"
                 using y \<open>\<not> p < i\<close> by simp
               also have "\<dots> < d i"
                 using ed3 [OF False] \<open>e > 0\<close> by simp
               finally show "\<bar>y i - x i\<bar> < d i" .
             qed
           qed auto
         qed
       qed auto
       with UV show "y \<in> U"
         by blast
     qed (use U in auto)
   qed
   then obtain e U where
       eU: "\<And>x. x \<in> standard_simplex p \<Longrightarrow>
                 0 < e x \<and> U x \<in> \<C> \<and> x \<in> U x"
       and  UI: "\<And>x y. \<lbrakk>x \<in> standard_simplex p;  \<And>i. i \<le> p \<Longrightarrow> \<bar>y i - x i\<bar> \<le> 2 * e x; \<And>i. i > p \<Longrightarrow> y i = 0\<rbrakk>
                        \<Longrightarrow> y \<in> U x"
     by metis
   define F where "F \<equiv> \<lambda>x. Pi\<^sub>E UNIV (\<lambda>i. if i \<le> p then {x i - e x<..<x i + e x} else UNIV)"
   have "\<forall>S \<in> F ` standard_simplex p. openin (powertop_real UNIV) S"
     by (simp add: F_def openin_PiE_gen)
   moreover have pF: "standard_simplex p \<subseteq> \<Union>(F ` standard_simplex p)"
     by (force simp: F_def PiE_iff eU)
   ultimately have "\<exists>\<F>. finite \<F> \<and> \<F> \<subseteq> F ` standard_simplex p \<and> standard_simplex p \<subseteq> \<Union>\<F>"
     using compactin_standard_simplex [of p]
     unfolding compactin_def by force
   then obtain S where "finite S" and ssp: "S \<subseteq> standard_simplex p" "standard_simplex p \<subseteq> \<Union>(F ` S)"
     unfolding ex_finite_subset_image by (auto simp: ex_finite_subset_image)
   then have "S \<noteq> {}"
     by (auto simp: nonempty_standard_simplex)
   show ?thesis
   proof
     show "Inf (e ` S) > 0"
       using \<open>finite S\<close> \<open>S \<noteq> {}\<close> ssp eU by (auto simp: finite_less_Inf_iff)
     fix k :: "(nat \<Rightarrow> real) set"
     assume k: "k \<subseteq> standard_simplex p"
          and kle: "\<And>x y i. \<lbrakk>i \<le> p; x \<in> k; y \<in> k\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> Inf (e ` S)"
     show "\<exists>U. U \<in> \<C> \<and> k \<subseteq> U"
     proof (cases "k = {}")
       case True
       then show ?thesis
         using \<open>S \<noteq> {}\<close> eU equals0I ssp(1) subset_eq p by auto
     next
       case False
       with k ssp obtain x a where "x \<in> k" "x \<in> standard_simplex p"
                             and a: "a \<in> S" and Fa: "x \<in> F a"
         by blast
       then have le_ea: "\<And>i. i \<le> p \<Longrightarrow> abs (x i - a i) < e a"
         by (simp add: F_def PiE_iff if_distrib abs_diff_less_iff cong: if_cong)
       show ?thesis
       proof (intro exI conjI)
         show "U a \<in> \<C>"
           using a eU ssp(1) by auto
         show "k \<subseteq> U a"
         proof clarify
           fix y assume "y \<in> k"
           with k have y: "y \<in> standard_simplex p"
             by blast
           show "y \<in> U a"
           proof (rule UI)
             show "a \<in> standard_simplex p"
               using a ssp(1) by auto
             fix i :: "nat"
             assume "i \<le> p"
             then have "\<bar>x i - y i\<bar> \<le> e a"
               by (meson kle [OF \<open>i \<le> p\<close>] a \<open>finite S\<close> \<open>x \<in> k\<close> \<open>y \<in> k\<close> cInf_le_finite finite_imageI imageI order_trans)
             then show "\<bar>y i - a i\<bar> \<le> 2 * e a"
               using le_ea [OF \<open>i \<le> p\<close>] by linarith
           next
             fix i assume "p < i"
             then show "y i = 0"
               using standard_simplex_def y by auto
           qed
         qed
       qed
     qed
   qed
 qed
 
 
 proposition sufficient_iterated_singular_subdivision_exists:
   assumes \<C>: "\<And>U. U \<in> \<C> \<Longrightarrow> openin X U"
       and X: "topspace X \<subseteq> \<Union>\<C>"
       and p: "singular_chain p X c"
   obtains n where "\<And>m f. \<lbrakk>n \<le> m; f \<in> Poly_Mapping.keys ((singular_subdivision p ^^ m) c)\<rbrakk>
                       \<Longrightarrow> \<exists>V \<in> \<C>. f ` (standard_simplex p) \<subseteq> V"
 proof (cases "c = 0")
   case False
   then show ?thesis
   proof (cases "topspace X = {}")
     case True
     show ?thesis
       using p that by (force simp: singular_chain_empty True)
   next
     case False
     show ?thesis
     proof (cases "\<C> = {}")
       case True
       then show ?thesis
         using False X by blast
     next
       case False
       have "\<exists>e. 0 < e \<and>
                 (\<forall>K. K \<subseteq> standard_simplex p \<longrightarrow> (\<forall>x y i. x \<in> K \<and> y \<in> K \<and> i \<le> p \<longrightarrow> \<bar>x i - y i\<bar> \<le> e)
                      \<longrightarrow> (\<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V))"
         if f: "f \<in> Poly_Mapping.keys c" for f
       proof -
         have ssf: "singular_simplex p X f"
           using f p by (auto simp: singular_chain_def)
         then have fp: "\<And>x. x \<in> standard_simplex p \<Longrightarrow> f x \<in> topspace X"
           by (auto simp: singular_simplex_def image_subset_iff dest: continuous_map_image_subset_topspace)
         have "\<exists>T. openin (powertop_real UNIV) T \<and>
                     standard_simplex p \<inter> f -` V = T \<inter> standard_simplex p"
           if V: "V \<in> \<C>" for V
         proof -
           have "singular_simplex p X f"
             using p f unfolding singular_chain_def by blast
           then have "openin (subtopology (powertop_real UNIV) (standard_simplex p))
                             {x \<in> standard_simplex p. f x \<in> V}"
             using \<C> [OF \<open>V \<in> \<C>\<close>] by (simp add: singular_simplex_def continuous_map_def)
           moreover have "standard_simplex p \<inter> f -` V = {x \<in> standard_simplex p. f x \<in> V}"
             by blast
           ultimately show ?thesis
             by (simp add: openin_subtopology)
         qed
         then obtain g where gope: "\<And>V. V \<in> \<C> \<Longrightarrow> openin (powertop_real UNIV) (g V)"
                 and geq: "\<And>V. V \<in> \<C> \<Longrightarrow> standard_simplex p \<inter> f -` V = g V \<inter> standard_simplex p"
           by metis
         obtain d where "0 < d"
               and d: "\<And>K. \<lbrakk>K \<subseteq> standard_simplex p; \<And>x y i. \<lbrakk>i \<le> p; x \<in> K; y \<in> K\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> d\<rbrakk>
                        \<Longrightarrow> \<exists>U. U \<in> g ` \<C> \<and> K \<subseteq> U"
         proof (rule llemma [of p "g ` \<C>"])
           show "standard_simplex p \<subseteq> \<Union>(g ` \<C>)"
             using geq X fp by (fastforce simp add:)
           show "openin (powertop_real UNIV) U" if "U \<in> g ` \<C>" for U :: "(nat \<Rightarrow> real) set"
             using gope that by blast
         qed auto
         show ?thesis
         proof (rule exI, intro allI conjI impI)
           fix K :: "(nat \<Rightarrow> real) set"
           assume K: "K \<subseteq> standard_simplex p"
              and Kd: "\<forall>x y i. x \<in> K \<and> y \<in> K \<and> i \<le> p \<longrightarrow> \<bar>x i - y i\<bar> \<le> d"
           then have "\<exists>U. U \<in> g ` \<C> \<and> K \<subseteq> U"
             using d [OF K] by auto
           then show "\<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V"
             using K geq by fastforce
         qed (rule \<open>d > 0\<close>)
       qed
       then obtain \<psi> where epos: "\<forall>f \<in> Poly_Mapping.keys c. 0 < \<psi> f"
                  and e: "\<And>f K. \<lbrakk>f \<in> Poly_Mapping.keys c; K \<subseteq> standard_simplex p;
                                 \<And>x y i. x \<in> K \<and> y \<in> K \<and> i \<le> p \<Longrightarrow> \<bar>x i - y i\<bar> \<le> \<psi> f\<rbrakk>
                                \<Longrightarrow> \<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V"
         by metis
       obtain d where "0 < d"
                and d: "\<And>f K. \<lbrakk>f \<in> Poly_Mapping.keys c; K \<subseteq> standard_simplex p;
                               \<And>x y i. \<lbrakk>x \<in> K; y \<in> K; i \<le> p\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> d\<rbrakk>
                               \<Longrightarrow> \<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V"
       proof
         show "Inf (\<psi> ` Poly_Mapping.keys c) > 0"
           by (simp add: finite_less_Inf_iff \<open>c \<noteq> 0\<close> epos)
         fix f K
         assume fK: "f \<in> Poly_Mapping.keys c" "K \<subseteq> standard_simplex p"
           and le: "\<And>x y i. \<lbrakk>x \<in> K; y \<in> K; i \<le> p\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> Inf (\<psi> ` Poly_Mapping.keys c)"
         then have lef: "Inf (\<psi> ` Poly_Mapping.keys c) \<le> \<psi> f"
           by (auto intro: cInf_le_finite)
         show "\<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V"
           using le lef by (blast intro: dual_order.trans e [OF fK])
       qed
       let ?d = "\<lambda>m. (simplicial_subdivision p ^^ m) (frag_of (restrict id (standard_simplex p)))"
       obtain n where n: "(p / (Suc p)) ^ n < d"
         using real_arch_pow_inv \<open>0 < d\<close> by fastforce
       show ?thesis
       proof
         fix m h
         assume "n \<le> m" and "h \<in> Poly_Mapping.keys ((singular_subdivision p ^^ m) c)"
         then obtain f where "f \<in> Poly_Mapping.keys c" "h \<in> Poly_Mapping.keys (chain_map p f (?d m))"
           using subsetD [OF keys_frag_extend] iterated_singular_subdivision [OF p, of m] by force
         then obtain g where g: "g \<in> Poly_Mapping.keys (?d m)" and heq: "h = restrict (f \<circ> g) (standard_simplex p)"
           using keys_frag_extend by (force simp: chain_map_def simplex_map_def)
         have xx: "simplicial_chain p (standard_simplex p) (?d n) \<and>
                   (\<forall>f \<in> Poly_Mapping.keys(?d n). \<forall>x \<in> standard_simplex p. \<forall>y \<in> standard_simplex p.
                        \<bar>f x i - f y i\<bar> \<le> (p / (Suc p)) ^ n)"
           for n i
         proof (induction n)
           case 0
           have "simplicial_simplex p (standard_simplex p) (\<lambda>a\<in>standard_simplex p. a)"
             by (metis eq_id_iff order_refl simplicial_simplex_id)
           moreover have "(\<forall>x\<in>standard_simplex p. \<forall>y\<in>standard_simplex p. \<bar>x i - y i\<bar> \<le> 1)"
             unfolding standard_simplex_def
             by (auto simp: abs_if dest!: spec [where x=i])
           ultimately show ?case
             unfolding power_0 funpow_0 by simp
         next
           case (Suc n)
           show ?case
             unfolding power_Suc funpow.simps o_def
           proof (intro conjI ballI)
             show "simplicial_chain p (standard_simplex p) (simplicial_subdivision p (?d n))"
               by (simp add: Suc simplicial_chain_simplicial_subdivision)
             show "\<bar>f x i - f y i\<bar> \<le> real p / real (Suc p) * (real p / real (Suc p)) ^ n"
               if "f \<in> Poly_Mapping.keys (simplicial_subdivision p (?d n))"
                 and "x \<in> standard_simplex p" and "y \<in> standard_simplex p" for f x y
               using Suc that by (blast intro: simplicial_subdivision_shrinks)
           qed
         qed
         have "g ` standard_simplex p \<subseteq> standard_simplex p"
           using g xx [of m] unfolding simplicial_chain_def simplicial_simplex by auto
         moreover
         have "\<bar>g x i - g y i\<bar> \<le> d" if "i \<le> p" "x \<in> standard_simplex p" "y \<in> standard_simplex p" for x y i
         proof -
           have "\<bar>g x i - g y i\<bar> \<le> (p / (Suc p)) ^ m"
             using g xx [of m] that by blast
           also have "\<dots> \<le> (p / (Suc p)) ^ n"
             by (auto intro: power_decreasing [OF \<open>n \<le> m\<close>])
           finally show ?thesis using n by simp
         qed
         then have "\<bar>x i - y i\<bar> \<le> d"
           if "x \<in> g ` (standard_simplex p)" "y \<in> g ` (standard_simplex p)" "i \<le> p" for i x y
           using that by blast
         ultimately show "\<exists>V\<in>\<C>. h ` standard_simplex p \<subseteq> V"
           using \<open>f \<in> Poly_Mapping.keys c\<close> d [of f "g ` standard_simplex p"]
           by (simp add: Bex_def heq image_image)
       qed
     qed
   qed
 qed force
 
 
 lemma small_homologous_rel_relcycle_exists:
   assumes \<C>: "\<And>U. U \<in> \<C> \<Longrightarrow> openin X U"
       and X: "topspace X \<subseteq> \<Union>\<C>"
       and p: "singular_relcycle p X S c"
     obtains c' where "singular_relcycle p X S c'" "homologous_rel p X S c c'"
                       "\<And>f. f \<in> Poly_Mapping.keys c' \<Longrightarrow> \<exists>V \<in> \<C>. f ` (standard_simplex p) \<subseteq> V"
 proof -
   have "singular_chain p X c"
        "(chain_boundary p c, 0) \<in> (mod_subset (p - Suc 0) (subtopology X S))"
     using p unfolding singular_relcycle_def by auto
   then obtain n where n: "\<And>m f. \<lbrakk>n \<le> m; f \<in> Poly_Mapping.keys ((singular_subdivision p ^^ m) c)\<rbrakk>
                             \<Longrightarrow> \<exists>V \<in> \<C>. f ` (standard_simplex p) \<subseteq> V"
     by (blast intro: sufficient_iterated_singular_subdivision_exists [OF \<C> X])
   let ?c' = "(singular_subdivision p ^^ n) c"
   show ?thesis
   proof
     show "homologous_rel p X S c ?c'"
       apply (induction n, simp_all)
       by (metis p homologous_rel_singular_subdivision homologous_rel_singular_relcycle homologous_rel_trans homologous_rel_sym)
     then show "singular_relcycle p X S ?c'"
       by (metis homologous_rel_singular_relcycle p)
   next
     fix f :: "(nat \<Rightarrow> real) \<Rightarrow> 'a"
     assume "f \<in> Poly_Mapping.keys ?c'"
     then show "\<exists>V\<in>\<C>. f ` standard_simplex p \<subseteq> V"
       by (rule n [OF order_refl])
   qed
 qed
 
 lemma excised_chain_exists:
   fixes S :: "'a set"
   assumes "X closure_of U \<subseteq> X interior_of T" "T \<subseteq> S" "singular_chain p (subtopology X S) c"
   obtains n d e where "singular_chain p (subtopology X (S - U)) d"
                       "singular_chain p (subtopology X T) e"
                       "(singular_subdivision p ^^ n) c = d + e"
 proof -
   have *: "\<exists>n d e. singular_chain p (subtopology X (S - U)) d \<and>
                   singular_chain p (subtopology X T) e \<and>
                   (singular_subdivision p ^^ n) c = d + e"
     if c: "singular_chain p (subtopology X S) c"
        and X: "X closure_of U \<subseteq> X interior_of T" "U \<subseteq> topspace X" and S: "T \<subseteq> S" "S \<subseteq> topspace X"
        for p X c S and T U :: "'a set"
   proof -
     obtain n where n: "\<And>m f. \<lbrakk>n \<le> m; f \<in> Poly_Mapping.keys ((singular_subdivision p ^^ m) c)\<rbrakk>
                              \<Longrightarrow> \<exists>V \<in> {S \<inter> X interior_of T, S - X closure_of U}. f ` standard_simplex p \<subseteq> V"
       apply (rule sufficient_iterated_singular_subdivision_exists
                    [of "{S \<inter> X interior_of T, S - X closure_of U}"])
       using X S c
       by (auto simp: topspace_subtopology openin_subtopology_Int2 openin_subtopology_diff_closed)
     let ?c' = "\<lambda>n. (singular_subdivision p ^^ n) c"
     have "singular_chain p (subtopology X S) (?c' m)" for m
       by (induction m) (auto simp: singular_chain_singular_subdivision c)
     then have scp: "singular_chain p (subtopology X S) (?c' n)" .
 
     have SS: "Poly_Mapping.keys (?c' n) \<subseteq> singular_simplex_set p (subtopology X (S - U))
                               \<union> singular_simplex_set p (subtopology X T)"
     proof (clarsimp)
       fix f
       assume f: "f \<in> Poly_Mapping.keys ((singular_subdivision p ^^ n) c)"
          and non: "\<not> singular_simplex p (subtopology X T) f"
       show "singular_simplex p (subtopology X (S - U)) f"
         using n [OF order_refl f] scp f non closure_of_subset [OF \<open>U \<subseteq> topspace X\<close>] interior_of_subset [of X T]
         by (fastforce simp: image_subset_iff singular_simplex_subtopology singular_chain_def)
     qed
     show ?thesis
        unfolding singular_chain_def using frag_split [OF SS] by metis
   qed
   have "(subtopology X (topspace X \<inter> S)) = (subtopology X S)"
     by (metis subtopology_subtopology subtopology_topspace)
   with assms have c: "singular_chain p (subtopology X (topspace X \<inter> S)) c"
     by simp
   have Xsub: "X closure_of (topspace X \<inter> U) \<subseteq> X interior_of (topspace X \<inter> T)"
     using assms closure_of_restrict interior_of_restrict by fastforce
   obtain n d e where
     d: "singular_chain p (subtopology X (topspace X \<inter> S - topspace X \<inter> U)) d"
     and e: "singular_chain p (subtopology X (topspace X \<inter> T)) e"
     and de: "(singular_subdivision p ^^ n) c = d + e"
     using *[OF c Xsub, simplified] assms by force
   show thesis
   proof
     show "singular_chain p (subtopology X (S - U)) d"
       by (metis d Diff_Int_distrib inf.cobounded2 singular_chain_mono)
     show "singular_chain p (subtopology X T) e"
       by (metis e inf.cobounded2 singular_chain_mono)
     show "(singular_subdivision p ^^ n) c = d + e"
       by (rule de)
   qed
 qed
 
 
 lemma excised_relcycle_exists:
   fixes S :: "'a set"
   assumes X: "X closure_of U \<subseteq> X interior_of T" and "T \<subseteq> S"
       and c: "singular_relcycle p (subtopology X S) T c"
   obtains c' where "singular_relcycle p (subtopology X (S - U)) (T - U) c'"
                    "homologous_rel p (subtopology X S) T c c'"
 proof -
   have [simp]: "(S - U) \<inter> (T - U) = T - U" "S \<inter> T = T"
     using \<open>T \<subseteq> S\<close> by auto
   have scc: "singular_chain p (subtopology X S) c"
     and scp1: "singular_chain (p - Suc 0) (subtopology X T) (chain_boundary p c)"
     using c by (auto simp: singular_relcycle_def mod_subset_def subtopology_subtopology)
   obtain n d e where d: "singular_chain p (subtopology X (S - U)) d"
     and e: "singular_chain p (subtopology X T) e"
     and de: "(singular_subdivision p ^^ n) c = d + e"
     using excised_chain_exists [OF X \<open>T \<subseteq> S\<close> scc] .
   have scSUd: "singular_chain (p - Suc 0) (subtopology X (S - U)) (chain_boundary p d)"
     by (simp add: singular_chain_boundary d)
   have sccn: "singular_chain p (subtopology X S) ((singular_subdivision p ^^ n) c)" for n
     by (induction n) (auto simp: singular_chain_singular_subdivision scc)
   have "singular_chain (p - Suc 0) (subtopology X T) (chain_boundary p ((singular_subdivision p ^^ n) c))"
   proof (induction n)
     case (Suc n)
     then show ?case
       by (simp add: singular_chain_singular_subdivision chain_boundary_singular_subdivision [OF sccn])
   qed (auto simp: scp1)
   then have "singular_chain (p - Suc 0) (subtopology X T) (chain_boundary p ((singular_subdivision p ^^ n) c - e))"
     by (simp add: chain_boundary_diff singular_chain_diff singular_chain_boundary e)
   with de have scTd: "singular_chain (p - Suc 0) (subtopology X T) (chain_boundary p d)"
     by simp
   show thesis
   proof
     have "singular_chain (p - Suc 0) X (chain_boundary p d)"
       using scTd singular_chain_subtopology by blast
     with scSUd scTd have "singular_chain (p - Suc 0) (subtopology X (T - U)) (chain_boundary p d)"
       by (fastforce simp add: singular_chain_subtopology)
     then show "singular_relcycle p (subtopology X (S - U)) (T - U) d"
       by (auto simp: singular_relcycle_def mod_subset_def subtopology_subtopology d)
     have "homologous_rel p (subtopology X S) T (c-0) ((singular_subdivision p ^^ n) c - e)"
     proof (rule homologous_rel_diff)
       show "homologous_rel p (subtopology X S) T c ((singular_subdivision p ^^ n) c)"
       proof (induction n)
         case (Suc n)
         then show ?case
           apply simp
           apply (rule homologous_rel_trans)
           using c homologous_rel_singular_relcycle_1 homologous_rel_singular_subdivision homologous_rel_sym by blast
       qed auto
       show "homologous_rel p (subtopology X S) T 0 e"
         unfolding homologous_rel_def using e
         by (intro singular_relboundary_diff singular_chain_imp_relboundary; simp add: subtopology_subtopology)
     qed
     with de show "homologous_rel p (subtopology X S) T c d"
       by simp
   qed
 qed
 
 
 subsection\<open>Homotopy invariance\<close>
 
 theorem homotopic_imp_homologous_rel_chain_maps:
   assumes hom: "homotopic_with (\<lambda>h. h ` T \<subseteq> V) S U f g" and c: "singular_relcycle p S T c"
   shows "homologous_rel p U V (chain_map p f c) (chain_map p g c)"
 proof -
   note sum.atMost_Suc [simp del]
   have contf: "continuous_map S U f" and contg: "continuous_map S U g"
     using homotopic_with_imp_continuous_maps [OF hom] by metis+
   obtain h where conth: "continuous_map (prod_topology (top_of_set {0..1::real}) S) U h"
     and h0: "\<And>x. h(0, x) = f x"
     and h1: "\<And>x. h(1, x) = g x"
     and hV: "\<And>t x. \<lbrakk>0 \<le> t; t \<le> 1; x \<in> T\<rbrakk> \<Longrightarrow> h(t,x) \<in> V"
     using hom by (fastforce simp: homotopic_with_def)
   define vv where "vv \<equiv> \<lambda>j i. if i = Suc j then 1 else (0::real)"
   define ww where "ww \<equiv> \<lambda>j i. if i=0 \<or> i = Suc j then 1 else (0::real)"
   define simp where "simp \<equiv> \<lambda>q i. oriented_simplex (Suc q) (\<lambda>j. if j \<le> i then vv j else ww(j -1))"
   define pr where "pr \<equiv> \<lambda>q c. \<Sum>i\<le>q. frag_cmul ((-1) ^ i)
                                         (frag_of (simplex_map (Suc q) (\<lambda>z. h(z 0, c(z \<circ> Suc))) (simp q i)))"
   have ss_ss: "simplicial_simplex (Suc q) ({x. x 0 \<in> {0..1} \<and> (x \<circ> Suc) \<in> standard_simplex q}) (simp q i)"
     if "i \<le> q" for q i
   proof -
     have "(\<Sum>j\<le>Suc q. (if j \<le> i then vv j 0 else ww (j -1) 0) * x j) \<in> {0..1}"
       if "x \<in> standard_simplex (Suc q)" for x
     proof -
       have "(\<Sum>j\<le>Suc q. if j \<le> i then 0 else x j) \<le> sum x {..Suc q}"
         using that unfolding standard_simplex_def
         by (force intro!: sum_mono)
       with \<open>i \<le> q\<close> that show ?thesis
         by (simp add: vv_def ww_def standard_simplex_def if_distrib [of "\<lambda>u. u * _"] sum_nonneg cong: if_cong)
     qed
     moreover
     have "(\<lambda>k. \<Sum>j\<le>Suc q. (if j \<le> i then vv j k else ww (j -1) k) * x j) \<circ> Suc \<in> standard_simplex q"
       if "x \<in> standard_simplex (Suc q)" for x
     proof -
       have card: "({..q} \<inter> {k. Suc k = j}) = {j-1}" if "0 < j" "j \<le> Suc q" for j
         using that by auto
       have eq: "(\<Sum>j\<le>Suc q. \<Sum>k\<le>q. if j \<le> i then if k = j then x j else 0 else if Suc k = j then x j else 0)
               = (\<Sum>j\<le>Suc q. x j)"
         by (rule sum.cong [OF refl]) (use \<open>i \<le> q\<close> in \<open>simp add: sum.If_cases card\<close>)
       have "(\<Sum>j\<le>Suc q. if j \<le> i then if k = j then x j else 0 else if Suc k = j then x j else 0)
             \<le> sum x {..Suc q}" for k
         using that unfolding standard_simplex_def
         by (force intro!: sum_mono)
       then show ?thesis
         using \<open>i \<le> q\<close> that
         by (simp add: vv_def ww_def standard_simplex_def if_distrib [of "\<lambda>u. u * _"] sum_nonneg
             sum.swap [where A = "atMost q"] eq cong: if_cong)
     qed
     ultimately show ?thesis
       by (simp add: that simplicial_simplex_oriented_simplex simp_def image_subset_iff if_distribR)
   qed
   obtain prism where prism: "\<And>q. prism q 0 = 0"
     "\<And>q c. singular_chain q S c \<Longrightarrow> singular_chain (Suc q) U (prism q c)"
     "\<And>q c. singular_chain q (subtopology S T) c
                            \<Longrightarrow> singular_chain (Suc q) (subtopology U V) (prism q c)"
     "\<And>q c. singular_chain q S c
                            \<Longrightarrow> chain_boundary (Suc q) (prism q c) =
                                chain_map q g c - chain_map q f c - prism (q -1) (chain_boundary q c)"
   proof
     show "(frag_extend \<circ> pr) q 0 = 0" for q
       by (simp add: pr_def)
   next
     show "singular_chain (Suc q) U ((frag_extend \<circ> pr) q c)"
       if "singular_chain q S c" for q c
       using that [unfolded singular_chain_def]
     proof (induction c rule: frag_induction)
       case (one m)
       show ?case
       proof (simp add: pr_def, intro singular_chain_cmul singular_chain_sum)
         fix i :: "nat"
         assume "i \<in> {..q}"
         define X where "X = subtopology (powertop_real UNIV) {x. x 0 \<in> {0..1} \<and> (x \<circ> Suc) \<in> standard_simplex q}"
         show "singular_chain (Suc q) U
                  (frag_of (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))"
           unfolding singular_chain_of
         proof (rule singular_simplex_simplex_map)
           show "singular_simplex (Suc q) X (simp q i)"
             unfolding X_def using \<open>i \<in> {..q}\<close> simplicial_imp_singular_simplex ss_ss by blast
           have 0: "continuous_map X (top_of_set {0..1}) (\<lambda>x. x 0)"
             unfolding continuous_map_in_subtopology topspace_subtopology X_def
             by (auto intro: continuous_map_product_projection continuous_map_from_subtopology)
           have 1: "continuous_map X S (m \<circ> (\<lambda>x j. x (Suc j)))"
           proof (rule continuous_map_compose)
             have "continuous_map (powertop_real UNIV) (powertop_real UNIV) (\<lambda>x j. x (Suc j))"
               by (auto intro: continuous_map_product_projection)
             then show "continuous_map X (subtopology (powertop_real UNIV) (standard_simplex q)) (\<lambda>x j. x (Suc j))"
               unfolding X_def o_def
               by (auto simp: continuous_map_in_subtopology intro: continuous_map_from_subtopology continuous_map_product_projection)
           qed (use one in \<open>simp add: singular_simplex_def\<close>)
           show "continuous_map X U (\<lambda>z. h (z 0, m (z \<circ> Suc)))"
             apply (rule continuous_map_compose [unfolded o_def, OF _ conth])
             using 0 1 by (simp add: continuous_map_pairwise o_def)
         qed
       qed
     next
       case (diff a b)
       then show ?case
         apply (simp add: frag_extend_diff keys_diff)
         using singular_chain_def singular_chain_diff by blast
     qed auto
   next
     show "singular_chain (Suc q) (subtopology U V) ((frag_extend \<circ> pr) q c)"
       if "singular_chain q (subtopology S T) c" for q c
       using that [unfolded singular_chain_def]
     proof (induction c rule: frag_induction)
       case (one m)
       show ?case
       proof (simp add: pr_def, intro singular_chain_cmul singular_chain_sum)
         fix i :: "nat"
         assume "i \<in> {..q}"
         define X where "X = subtopology (powertop_real UNIV) {x. x 0 \<in> {0..1} \<and> (x \<circ> Suc) \<in> standard_simplex q}"
         show "singular_chain (Suc q) (subtopology U V)
                  (frag_of (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))"
           unfolding singular_chain_of
         proof (rule singular_simplex_simplex_map)
           show "singular_simplex (Suc q) X (simp q i)"
             unfolding X_def using \<open>i \<in> {..q}\<close> simplicial_imp_singular_simplex ss_ss by blast
           have 0: "continuous_map X (top_of_set {0..1}) (\<lambda>x. x 0)"
             unfolding continuous_map_in_subtopology topspace_subtopology X_def
             by (auto intro: continuous_map_product_projection continuous_map_from_subtopology)
           have 1: "continuous_map X (subtopology S T) (m \<circ> (\<lambda>x j. x (Suc j)))"
           proof (rule continuous_map_compose)
             have "continuous_map (powertop_real UNIV) (powertop_real UNIV) (\<lambda>x j. x (Suc j))"
               by (auto intro: continuous_map_product_projection)
             then show "continuous_map X (subtopology (powertop_real UNIV) (standard_simplex q)) (\<lambda>x j. x (Suc j))"
               unfolding X_def o_def
               by (auto simp: continuous_map_in_subtopology intro: continuous_map_from_subtopology continuous_map_product_projection)
             show "continuous_map (subtopology (powertop_real UNIV) (standard_simplex q)) (subtopology S T) m"
               using one continuous_map_into_fulltopology by (auto simp: singular_simplex_def)
           qed
           have "continuous_map X (subtopology U V) (h \<circ> (\<lambda>z. (z 0, m (z \<circ> Suc))))"
           proof (rule continuous_map_compose)
             show "continuous_map X (prod_topology (top_of_set {0..1::real}) (subtopology S T)) (\<lambda>z. (z 0, m (z \<circ> Suc)))"
               using 0 1 by (simp add: continuous_map_pairwise o_def)
             have "continuous_map (subtopology (prod_topology euclideanreal S) ({0..1} \<times> T)) U h"
               by (metis conth continuous_map_from_subtopology subtopology_Times subtopology_topspace)
             with hV show "continuous_map (prod_topology (top_of_set {0..1::real}) (subtopology S T)) (subtopology U V) h"
               by (force simp: topspace_subtopology continuous_map_in_subtopology subtopology_restrict subtopology_Times)
           qed
           then show "continuous_map X (subtopology U V) (\<lambda>z. h (z 0, m (z \<circ> Suc)))"
             by (simp add: o_def)
         qed
       qed
     next
       case (diff a b)
       then show ?case
         by (metis comp_apply frag_extend_diff singular_chain_diff)
     qed auto
   next
     show "chain_boundary (Suc q) ((frag_extend \<circ> pr) q c) =
         chain_map q g c - chain_map q f c - (frag_extend \<circ> pr) (q -1) (chain_boundary q c)"
       if "singular_chain q S c" for q c
       using that [unfolded singular_chain_def]
     proof (induction c rule: frag_induction)
       case (one m)
       have eq2: "Sigma S T = (\<lambda>i. (i,i)) ` {i \<in> S. i \<in> T i} \<union> (Sigma S (\<lambda>i. T i - {i}))" for S :: "nat set" and T
         by force
       have 1: "(\<Sum>(i,j)\<in>(\<lambda>i. (i, i)) ` {i. i \<le> q \<and> i \<le> Suc q}.
                    frag_cmul (((-1) ^ i) * (-1) ^ j)
                       (frag_of
                         (singular_face (Suc q) j
                           (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
              + (\<Sum>(i,j)\<in>(\<lambda>i. (i, i)) ` {i. i \<le> q}.
                      frag_cmul (- ((-1) ^ i * (-1) ^ j))
                         (frag_of
                           (singular_face (Suc q) (Suc j)
                             (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
              = frag_of (simplex_map q g m) - frag_of (simplex_map q f m)"
       proof -
         have "restrict ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q 0 \<circ> simplical_face 0)) (standard_simplex q)
           = restrict (g \<circ> m) (standard_simplex q)"
         proof (rule restrict_ext)
           fix x
           assume x: "x \<in> standard_simplex q"
           have "(\<Sum>j\<le>Suc q. if j = 0 then 0 else x (j - Suc 0)) = (\<Sum>j\<le>q. x j)"
             by (simp add: sum.atMost_Suc_shift)
           with x have "simp q 0 (simplical_face 0 x) 0 = 1"
             apply (simp add: oriented_simplex_def simp_def simplical_face_in_standard_simplex)
             apply (simp add: simplical_face_def if_distrib ww_def standard_simplex_def cong: if_cong)
             done
           moreover
           have "(\<lambda>n. if n \<le> q then x n else 0) = x"
             using standard_simplex_def x by auto
           then have "(\<lambda>n. simp q 0 (simplical_face 0 x) (Suc n)) = x"
             unfolding oriented_simplex_def simp_def ww_def using x
             apply (simp add: simplical_face_in_standard_simplex)
             apply (simp add: simplical_face_def if_distrib)
             apply (simp add: if_distribR if_distrib cong: if_cong)
             done
           ultimately show "((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q 0 \<circ> simplical_face 0)) x = (g \<circ> m) x"
             by (simp add: o_def h1)
         qed
         then have a: "frag_of (singular_face (Suc q) 0 (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q 0)))
              = frag_of (simplex_map q g m)"
           by (simp add: singular_face_simplex_map) (simp add: simplex_map_def)
         have "restrict ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q q \<circ> simplical_face (Suc q))) (standard_simplex q)
           = restrict (f \<circ> m) (standard_simplex q)"
         proof (rule restrict_ext)
           fix x
           assume x: "x \<in> standard_simplex q"
           then have "simp q q (simplical_face (Suc q) x) 0 = 0"
             unfolding oriented_simplex_def simp_def
             by (simp add: simplical_face_in_standard_simplex sum.atMost_Suc) (simp add: simplical_face_def vv_def)
           moreover have "(\<lambda>n. simp q q (simplical_face (Suc q) x) (Suc n)) = x"
             unfolding oriented_simplex_def simp_def vv_def using x
             apply (simp add: simplical_face_in_standard_simplex)
             apply (force simp: standard_simplex_def simplical_face_def if_distribR if_distrib [of "\<lambda>x. x * _"] sum.atMost_Suc cong: if_cong)
             done
           ultimately show "((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q q \<circ> simplical_face (Suc q))) x = (f \<circ> m) x"
             by (simp add: o_def h0)
         qed
         then have b: "frag_of (singular_face (Suc q) (Suc q)
                      (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q q)))
           = frag_of (simplex_map q f m)"
           by (simp add: singular_face_simplex_map) (simp add: simplex_map_def)
         have sfeq: "simplex_map q (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q (Suc i) \<circ> simplical_face (Suc i))
                 = simplex_map q (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i \<circ> simplical_face (Suc i))"
           if "i < q" for i
           unfolding simplex_map_def
         proof (rule restrict_ext)
           fix x
           assume "x \<in> standard_simplex q"
           then have "(simp q (Suc i) \<circ> simplical_face (Suc i)) x = (simp q i \<circ> simplical_face (Suc i)) x"
             unfolding oriented_simplex_def simp_def simplical_face_def
             by (force intro: sum.cong)
           then show "((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q (Suc i) \<circ> simplical_face (Suc i))) x
                  = ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q i \<circ> simplical_face (Suc i))) x"
             by simp
         qed
         have eqq: "{i. i \<le> q \<and> i \<le> Suc q} = {..q}"
           by force
         have qeq: "{..q} = insert 0 ((\<lambda>i. Suc i) ` {i. i < q})" "{i. i \<le> q} = insert q {i. i < q}"
           using le_imp_less_Suc less_Suc_eq_0_disj by auto
         show ?thesis
           using a b
           apply (simp add: sum.reindex inj_on_def eqq)
           apply (simp add: qeq sum.insert_if sum.reindex sum_negf singular_face_simplex_map sfeq)
           done
       qed
       have 2: "(\<Sum>(i,j)\<in>(SIGMA i:{..q}. {0..min (Suc q) i} - {i}).
                      frag_cmul ((-1) ^ i * (-1) ^ j)
                       (frag_of
                         (singular_face (Suc q) j
                           (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
              + (\<Sum>(i,j)\<in>(SIGMA i:{..q}. {i..q} - {i}).
                  frag_cmul (- ((-1) ^ i * (-1) ^ j))
                   (frag_of
                     (singular_face (Suc q) (Suc j)
                       (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
              = - frag_extend (pr (q - Suc 0)) (chain_boundary q (frag_of m))"
       proof (cases "q=0")
         case True
         then show ?thesis
           by (simp add: chain_boundary_def flip: sum.Sigma)
       next
         case False
         have eq: "{..q - Suc 0} \<times> {..q} = Sigma {..q - Suc 0} (\<lambda>i. {0..min q i}) \<union> Sigma {..q} (\<lambda>i. {i<..q})"
           by force
         have I: "(\<Sum>(i,j)\<in>(SIGMA i:{..q}. {0..min (Suc q) i} - {i}).
                     frag_cmul ((-1) ^ (i + j))
                       (frag_of
                         (singular_face (Suc q) j
                           (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
                = (\<Sum>(i,j)\<in>(SIGMA i:{..q - Suc 0}. {0..min q i}).
                    frag_cmul (- ((-1) ^ (j + i)))
                     (frag_of
                       (simplex_map q (\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc)))
                         (simp (q - Suc 0) i))))"
         proof -
           have seq: "simplex_map q (\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc)))
                        (simp (q - Suc 0) (i - Suc 0))
                    = simplex_map q (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i \<circ> simplical_face j)"
             if ij: "i \<le> q" "j \<noteq> i" "j \<le> i" for i j
             unfolding simplex_map_def
           proof (rule restrict_ext)
             fix x
             assume x: "x \<in> standard_simplex q"
             have "i > 0"
               using that by force
             then have iq: "i - Suc 0 \<le> q - Suc 0"
               using \<open>i \<le> q\<close> False by simp
             have q0_eq: "{..Suc q} = insert 0 (Suc ` {..q})"
               by (auto simp: image_def gr0_conv_Suc)
             have \<alpha>: "simp (q - Suc 0) (i - Suc 0) x 0 = simp q i (simplical_face j x) 0"
               using False x ij
               unfolding oriented_simplex_def simp_def vv_def ww_def
               apply (simp add: simplical_face_in_standard_simplex)
               apply (force simp: simplical_face_def q0_eq sum.reindex intro!: sum.cong)
               done
             have \<beta>: "simplical_face j (simp (q - Suc 0) (i - Suc 0) x \<circ> Suc) = simp q i (simplical_face j x) \<circ> Suc"
             proof
               fix k
               show "simplical_face j (simp (q - Suc 0) (i - Suc 0) x \<circ> Suc) k
                   = (simp q i (simplical_face j x) \<circ> Suc) k"
                 using False x ij
                 unfolding oriented_simplex_def simp_def o_def vv_def ww_def
                 apply (simp add: simplical_face_in_standard_simplex if_distribR)
                 apply (simp add: simplical_face_def if_distrib [of "\<lambda>u. u * _"] cong: if_cong)
                 apply (intro impI conjI)
                  apply (force simp: sum.atMost_Suc intro: sum.cong)
                 apply (force simp: q0_eq sum.reindex intro!: sum.cong)
                 done
             qed
             have "simp (q - Suc 0) (i - Suc 0) x \<circ> Suc \<in> standard_simplex (q - Suc 0)"
               using ss_ss [OF iq] \<open>i \<le> q\<close> False \<open>i > 0\<close>
               apply (simp add: simplicial_simplex image_subset_iff)
               using \<open>x \<in> standard_simplex q\<close> by blast
             then show "((\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc))) \<circ> simp (q - Suc 0) (i - Suc 0)) x
                 = ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q i \<circ> simplical_face j)) x"
               by (simp add: singular_face_def \<alpha> \<beta>)
           qed
           have [simp]: "(-1::int) ^ (i + j - Suc 0) = - ((-1) ^ (i + j))" if "i \<noteq> j" for i j::nat
           proof -
             have "i + j > 0"
               using that by blast
             then show ?thesis
               by (metis (no_types, hide_lams) One_nat_def Suc_diff_1 add.inverse_inverse mult.left_neutral mult_minus_left power_Suc)
           qed
           show ?thesis
             apply (rule sum.eq_general_inverses [where h = "\<lambda>(a,b). (a-1,b)" and k = "\<lambda>(a,b). (Suc a,b)"])
             using False apply (auto simp: singular_face_simplex_map seq add.commute)
             done
         qed
         have *: "singular_face (Suc q) (Suc j) (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i))
                = simplex_map q (\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc))) (simp (q - Suc 0) i)"
           if ij: "i < j" "j \<le> q" for i j
         proof -
           have iq: "i \<le> q - Suc 0"
             using that by auto
           have sf_eqh: "singular_face (Suc q) (Suc j)
                            (\<lambda>x. if x \<in> standard_simplex (Suc q)
                                 then ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> simp q i) x else undefined) x
                       = h (simp (q - Suc 0) i x 0,
                            singular_face q j m (\<lambda>xa. simp (q - Suc 0) i x (Suc xa)))"
             if x: "x \<in> standard_simplex q" for x
           proof -
             let ?f = "\<lambda>k. \<Sum>j\<le>q. if j \<le> i then if k = j then x j else 0
                                else if Suc k = j then x j else 0"
             have fm: "simplical_face (Suc j) x \<in> standard_simplex (Suc q)"
               using ss_ss [OF iq] that ij
               by (simp add: simplical_face_in_standard_simplex)
             have ss: "?f \<in> standard_simplex (q - Suc 0)"
               unfolding standard_simplex_def
             proof (intro CollectI conjI impI allI)
               fix k
               show "0 \<le> ?f k"
                 using that by (simp add: sum_nonneg standard_simplex_def)
               show "?f k \<le> 1"
                 using x sum_le_included [of "{..q}" "{..q}" x "id"]
                 by (simp add: standard_simplex_def)
               assume k: "q - Suc 0 < k"
               show "?f k = 0"
                 by (rule sum.neutral) (use that x iq k standard_simplex_def in auto)
             next
               have "(\<Sum>k\<le>q - Suc 0. ?f k)
                   = (\<Sum>(k,j) \<in> ({..q - Suc 0} \<times> {..q}) \<inter> {(k,j). if j \<le> i then k = j else Suc k = j}. x j)"
                 apply (simp add: sum.Sigma)
                 by (rule sum.mono_neutral_cong) (auto simp: split: if_split_asm)
               also have "\<dots> = sum x {..q}"
                 apply (rule sum.eq_general_inverses
                     [where h = "\<lambda>(k,j). if j\<le>i \<and> k=j \<or> j>i \<and> Suc k = j then j else Suc q"
                       and k = "\<lambda>j. if j \<le> i then (j,j) else (j - Suc 0, j)"])
                 using ij by auto
               also have "\<dots> = 1"
                 using x by (simp add: standard_simplex_def)
               finally show "(\<Sum>k\<le>q - Suc 0. ?f k) = 1"
                 by (simp add: standard_simplex_def)
             qed
             let ?g = "\<lambda>k. if k \<le> i then 0
                               else if k < Suc j then x k
                                    else if k = Suc j then 0 else x (k - Suc 0)"
             have eq: "{..Suc q} = {..j} \<union> {Suc j} \<union> Suc`{j<..q}" "{..q} = {..j} \<union> {j<..q}"
               using ij image_iff less_Suc_eq_0_disj less_Suc_eq_le
               by (force simp: image_iff)+
             then have "(\<Sum>k\<le>Suc q. ?g k) = (\<Sum>k\<in>{..j} \<union> {Suc j} \<union> Suc`{j<..q}. ?g k)"
               by simp
             also have "\<dots> = (\<Sum>k\<in>{..j} \<union> Suc`{j<..q}. ?g k)"
               by (rule sum.mono_neutral_right) auto
             also have "\<dots> = (\<Sum>k\<in>{..j}. ?g k) + (\<Sum>k\<in>Suc`{j<..q}. ?g k)"
               by (rule sum.union_disjoint) auto
             also have "\<dots> = (\<Sum>k\<in>{..j}. ?g k) + (\<Sum>k\<in>{j<..q}. ?g (Suc k))"
               by (auto simp: sum.reindex)
             also have "\<dots> = (\<Sum>k\<in>{..j}. if k \<le> i then 0 else x k)
                            + (\<Sum>k\<in>{j<..q}. if k \<le> i then 0 else x k)"
               by (intro sum.cong arg_cong2 [of concl: "(+)"]) (use ij in auto)
             also have "\<dots> = (\<Sum>k\<le>q. if k \<le> i then 0 else x k)"
               unfolding eq by (subst sum.union_disjoint) auto
             finally have "(\<Sum>k\<le>Suc q. ?g k) = (\<Sum>k\<le>q. if k \<le> i then 0 else x k)" .
             then have QQ: "(\<Sum>l\<le>Suc q. if l \<le> i then 0 else simplical_face (Suc j) x l) = (\<Sum>j\<le>q. if j \<le> i then 0 else x j)"
               by (simp add: simplical_face_def cong: if_cong)
             have WW: "(\<lambda>k. \<Sum>l\<le>Suc q. if l \<le> i
                                     then if k = l then simplical_face (Suc j) x l else 0
                                     else if Suc k = l then simplical_face (Suc j) x l
                                     else 0)
                 = simplical_face j
                    (\<lambda>k. \<Sum>j\<le>q. if j \<le> i then if k = j then x j else 0
                                 else if Suc k = j then x j else 0)"
             proof -
               have *: "(\<Sum>l\<le>q. if l \<le> i then 0 else if Suc k = l then x (l - Suc 0) else 0)
                     = (\<Sum>l\<le>q. if l \<le> i then if k - Suc 0 = l then x l else 0 else if k = l then x l else 0)"
                 (is "?lhs = ?rhs")
                 if "k \<noteq> q" "k > j" for k
               proof (cases "k \<le> q")
                 case True
                 have "?lhs = sum (\<lambda>l. x (l - Suc 0)) {Suc k}" "?rhs = sum x {k}"
                   by (rule sum.mono_neutral_cong_right; use True ij that in auto)+
                 then show ?thesis
                   by simp
               next
                 case False
                 have "?lhs = 0" "?rhs = 0"
                   by (rule sum.neutral; use False ij in auto)+
                 then show ?thesis
                   by simp
               qed
               show ?thesis
                 apply (rule ext)
                 unfolding simplical_face_def using ij
                 apply (auto simp: sum.atMost_Suc cong: if_cong)
                  apply (force simp flip: ivl_disj_un(2) intro: sum.neutral)
                  apply (auto simp: *)
                 done
             qed
             show ?thesis
               using False that iq
               unfolding oriented_simplex_def simp_def vv_def ww_def
               apply (simp add: if_distribR cong: if_cong)
               apply (simp add: simplical_face_def if_distrib [of "\<lambda>u. u * _"] o_def cong: if_cong)
               apply (simp add: singular_face_def fm ss QQ WW)
               done
           qed
           show ?thesis
             unfolding simplex_map_def restrict_def
             apply (simp add: simplicial_simplex image_subset_iff o_def sf_eqh fun_eq_iff)
             apply (simp add: singular_face_def)
             done
         qed
         have sgeq: "(SIGMA i:{..q}. {i..q} - {i})  = (SIGMA i:{..q}. {i<..q})"
           by force
         have II: "(\<Sum>(i,j)\<in>(SIGMA i:{..q}. {i..q} - {i}).
                      frag_cmul (- ((-1) ^ (i + j)))
                       (frag_of
                         (singular_face (Suc q) (Suc j)
                           (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i))))) =
                   (\<Sum>(i,j)\<in>(SIGMA i:{..q}. {i<..q}).
                      frag_cmul (- ((-1) ^ (j + i)))
                       (frag_of
                         (simplex_map q (\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc)))
                           (simp (q - Suc 0) i))))"
           by (force simp: * sgeq add.commute intro: sum.cong)
         show ?thesis
           using False
           apply (simp add: chain_boundary_def frag_extend_sum frag_extend_cmul frag_cmul_sum pr_def flip: sum_negf power_add)
           apply (subst sum.swap [where A = "{..q}"])
           apply (simp add: sum.cartesian_product eq sum.union_disjoint disjoint_iff_not_equal I II)
           done
       qed
       have *: "\<lbrakk>a+b = w; c+d = -z\<rbrakk> \<Longrightarrow> (a + c) + (b+d) = w-z" for a b w c d z :: "'c \<Rightarrow>\<^sub>0 int"
         by (auto simp: algebra_simps)
       have eq: "{..q} \<times> {..Suc q} =
                 Sigma {..q} (\<lambda>i. {0..min (Suc q) i})
               \<union> Sigma {..q} (\<lambda>i. {Suc i..Suc q})"
         by force
       show ?case
         apply (subst pr_def)
         apply (simp add: chain_boundary_sum chain_boundary_cmul)
         apply (subst chain_boundary_def)
         apply (simp add: frag_cmul_sum sum.cartesian_product eq sum.union_disjoint disjoint_iff_not_equal
                      sum.atLeast_Suc_atMost_Suc_shift del: sum.cl_ivl_Suc flip: comm_monoid_add_class.sum.Sigma)
         apply (simp add: comm_monoid_add_class.sum.Sigma eq2 [of _ "\<lambda>i. {_ i.._ i}"])
         apply (simp add: sum.union_disjoint disjoint_iff_not_equal * [OF 1 2])
         done
     next
       case (diff a b)
       then show ?case
         by (simp add: chain_boundary_diff frag_extend_diff chain_map_diff)
     qed auto
   qed
   have *: "singular_chain p (subtopology U V) (prism (p - Suc 0) (chain_boundary p c))"
     if "singular_chain p S c" "singular_chain (p - Suc 0) (subtopology S T) (chain_boundary p c)"
   proof (cases "p")
     case 0 then show ?thesis by (simp add: chain_boundary_def prism)
   next
     case (Suc p')
     with prism that show ?thesis by auto
   qed
   then show ?thesis
     using c
     unfolding singular_relcycle_def homologous_rel_def singular_relboundary_def mod_subset_def
     apply (rule_tac x="- prism p c" in exI)
     by (simp add: chain_boundary_minus prism(2) prism(4) singular_chain_minus)
 qed
 
 end
 
diff --git a/src/HOL/Library/Float.thy b/src/HOL/Library/Float.thy
--- a/src/HOL/Library/Float.thy
+++ b/src/HOL/Library/Float.thy
@@ -1,2446 +1,2446 @@
 (*  Title:      HOL/Library/Float.thy
     Author:     Johannes Hölzl, Fabian Immler
     Copyright   2012  TU München
 *)
 
 section \<open>Floating-Point Numbers\<close>
 
 theory Float
 imports Log_Nat Lattice_Algebras
 begin
 
 definition "float = {m * 2 powr e | (m :: int) (e :: int). True}"
 
 typedef float = float
   morphisms real_of_float float_of
   unfolding float_def by auto
 
 setup_lifting type_definition_float
 
 declare real_of_float [code_unfold]
 
 lemmas float_of_inject[simp]
 
 declare [[coercion "real_of_float :: float \<Rightarrow> real"]]
 
 lemma real_of_float_eq: "f1 = f2 \<longleftrightarrow> real_of_float f1 = real_of_float f2" for f1 f2 :: float
   unfolding real_of_float_inject ..
 
 declare real_of_float_inverse[simp] float_of_inverse [simp]
 declare real_of_float [simp]
 
 
 subsection \<open>Real operations preserving the representation as floating point number\<close>
 
 lemma floatI: "m * 2 powr e = x \<Longrightarrow> x \<in> float" for m e :: int
   by (auto simp: float_def)
 
 lemma zero_float[simp]: "0 \<in> float"
   by (auto simp: float_def)
 
 lemma one_float[simp]: "1 \<in> float"
   by (intro floatI[of 1 0]) simp
 
 lemma numeral_float[simp]: "numeral i \<in> float"
   by (intro floatI[of "numeral i" 0]) simp
 
 lemma neg_numeral_float[simp]: "- numeral i \<in> float"
   by (intro floatI[of "- numeral i" 0]) simp
 
 lemma real_of_int_float[simp]: "real_of_int x \<in> float" for x :: int
   by (intro floatI[of x 0]) simp
 
 lemma real_of_nat_float[simp]: "real x \<in> float" for x :: nat
   by (intro floatI[of x 0]) simp
 
 lemma two_powr_int_float[simp]: "2 powr (real_of_int i) \<in> float" for i :: int
   by (intro floatI[of 1 i]) simp
 
 lemma two_powr_nat_float[simp]: "2 powr (real i) \<in> float" for i :: nat
   by (intro floatI[of 1 i]) simp
 
 lemma two_powr_minus_int_float[simp]: "2 powr - (real_of_int i) \<in> float" for i :: int
   by (intro floatI[of 1 "-i"]) simp
 
 lemma two_powr_minus_nat_float[simp]: "2 powr - (real i) \<in> float" for i :: nat
   by (intro floatI[of 1 "-i"]) simp
 
 lemma two_powr_numeral_float[simp]: "2 powr numeral i \<in> float"
   by (intro floatI[of 1 "numeral i"]) simp
 
 lemma two_powr_neg_numeral_float[simp]: "2 powr - numeral i \<in> float"
   by (intro floatI[of 1 "- numeral i"]) simp
 
 lemma two_pow_float[simp]: "2 ^ n \<in> float"
   by (intro floatI[of 1 n]) (simp add: powr_realpow)
 
 
 lemma plus_float[simp]: "r \<in> float \<Longrightarrow> p \<in> float \<Longrightarrow> r + p \<in> float"
   unfolding float_def
 proof (safe, simp)
   have *: "\<exists>(m::int) (e::int). m1 * 2 powr e1 + m2 * 2 powr e2 = m * 2 powr e"
     if "e1 \<le> e2" for e1 m1 e2 m2 :: int
   proof -
     from that have "m1 * 2 powr e1 + m2 * 2 powr e2 = (m1 + m2 * 2 ^ nat (e2 - e1)) * 2 powr e1"
       by (simp add: powr_diff field_simps flip: powr_realpow)
     then show ?thesis
       by blast
   qed
   fix e1 m1 e2 m2 :: int
   consider "e2 \<le> e1" | "e1 \<le> e2" by (rule linorder_le_cases)
   then show "\<exists>(m::int) (e::int). m1 * 2 powr e1 + m2 * 2 powr e2 = m * 2 powr e"
   proof cases
     case 1
     from *[OF this, of m2 m1] show ?thesis
       by (simp add: ac_simps)
   next
     case 2
     then show ?thesis by (rule *)
   qed
 qed
 
 lemma uminus_float[simp]: "x \<in> float \<Longrightarrow> -x \<in> float"
   apply (auto simp: float_def)
   apply hypsubst_thin
   apply (rename_tac m e)
   apply (rule_tac x="-m" in exI)
   apply (rule_tac x="e" in exI)
   apply (simp add: field_simps)
   done
 
 lemma times_float[simp]: "x \<in> float \<Longrightarrow> y \<in> float \<Longrightarrow> x * y \<in> float"
   apply (auto simp: float_def)
   apply hypsubst_thin
   apply (rename_tac mx my ex ey)
   apply (rule_tac x="mx * my" in exI)
   apply (rule_tac x="ex + ey" in exI)
   apply (simp add: powr_add)
   done
 
 lemma minus_float[simp]: "x \<in> float \<Longrightarrow> y \<in> float \<Longrightarrow> x - y \<in> float"
   using plus_float [of x "- y"] by simp
 
 lemma abs_float[simp]: "x \<in> float \<Longrightarrow> \<bar>x\<bar> \<in> float"
   by (cases x rule: linorder_cases[of 0]) auto
 
 lemma sgn_of_float[simp]: "x \<in> float \<Longrightarrow> sgn x \<in> float"
   by (cases x rule: linorder_cases[of 0]) (auto intro!: uminus_float)
 
 lemma div_power_2_float[simp]: "x \<in> float \<Longrightarrow> x / 2^d \<in> float"
   apply (auto simp add: float_def)
   apply hypsubst_thin
   apply (rename_tac m e)
   apply (rule_tac x="m" in exI)
   apply (rule_tac x="e - d" in exI)
   apply (simp flip: powr_realpow powr_add add: field_simps)
   done
 
 lemma div_power_2_int_float[simp]: "x \<in> float \<Longrightarrow> x / (2::int)^d \<in> float"
   apply (auto simp add: float_def)
   apply hypsubst_thin
   apply (rename_tac m e)
   apply (rule_tac x="m" in exI)
   apply (rule_tac x="e - d" in exI)
   apply (simp flip: powr_realpow powr_add add: field_simps)
   done
 
 lemma div_numeral_Bit0_float[simp]:
   assumes "x / numeral n \<in> float"
   shows "x / (numeral (Num.Bit0 n)) \<in> float"
 proof -
   have "(x / numeral n) / 2^1 \<in> float"
     by (intro assms div_power_2_float)
   also have "(x / numeral n) / 2^1 = x / (numeral (Num.Bit0 n))"
     by (induct n) auto
   finally show ?thesis .
 qed
 
 lemma div_neg_numeral_Bit0_float[simp]:
   assumes "x / numeral n \<in> float"
   shows "x / (- numeral (Num.Bit0 n)) \<in> float"
 proof -
   have "- (x / numeral (Num.Bit0 n)) \<in> float"
     using assms by simp
   also have "- (x / numeral (Num.Bit0 n)) = x / - numeral (Num.Bit0 n)"
     by simp
   finally show ?thesis .
 qed
 
 lemma power_float[simp]:
   assumes "a \<in> float"
   shows "a ^ b \<in> float"
 proof -
   from assms obtain m e :: int where "a = m * 2 powr e"
     by (auto simp: float_def)
   then show ?thesis
     by (auto intro!: floatI[where m="m^b" and e = "e*b"]
       simp: power_mult_distrib powr_realpow[symmetric] powr_powr)
 qed
 
 lift_definition Float :: "int \<Rightarrow> int \<Rightarrow> float" is "\<lambda>(m::int) (e::int). m * 2 powr e"
   by simp
 declare Float.rep_eq[simp]
 
 code_datatype Float
 
 lemma compute_real_of_float[code]:
   "real_of_float (Float m e) = (if e \<ge> 0 then m * 2 ^ nat e else m / 2 ^ (nat (-e)))"
   by (simp add: powr_int)
 
 
 subsection \<open>Arithmetic operations on floating point numbers\<close>
 
 instantiation float :: "{ring_1,linorder,linordered_ring,linordered_idom,numeral,equal}"
 begin
 
 lift_definition zero_float :: float is 0 by simp
 declare zero_float.rep_eq[simp]
 
 lift_definition one_float :: float is 1 by simp
 declare one_float.rep_eq[simp]
 
 lift_definition plus_float :: "float \<Rightarrow> float \<Rightarrow> float" is "(+)" by simp
 declare plus_float.rep_eq[simp]
 
 lift_definition times_float :: "float \<Rightarrow> float \<Rightarrow> float" is "(*)" by simp
 declare times_float.rep_eq[simp]
 
 lift_definition minus_float :: "float \<Rightarrow> float \<Rightarrow> float" is "(-)" by simp
 declare minus_float.rep_eq[simp]
 
 lift_definition uminus_float :: "float \<Rightarrow> float" is "uminus" by simp
 declare uminus_float.rep_eq[simp]
 
 lift_definition abs_float :: "float \<Rightarrow> float" is abs by simp
 declare abs_float.rep_eq[simp]
 
 lift_definition sgn_float :: "float \<Rightarrow> float" is sgn by simp
 declare sgn_float.rep_eq[simp]
 
 lift_definition equal_float :: "float \<Rightarrow> float \<Rightarrow> bool" is "(=) :: real \<Rightarrow> real \<Rightarrow> bool" .
 
 lift_definition less_eq_float :: "float \<Rightarrow> float \<Rightarrow> bool" is "(\<le>)" .
 declare less_eq_float.rep_eq[simp]
 
 lift_definition less_float :: "float \<Rightarrow> float \<Rightarrow> bool" is "(<)" .
 declare less_float.rep_eq[simp]
 
 instance
   by standard (transfer; fastforce simp add: field_simps intro: mult_left_mono mult_right_mono)+
 
 end
 
 lemma real_of_float [simp]: "real_of_float (of_nat n) = of_nat n"
   by (induct n) simp_all
 
 lemma real_of_float_of_int_eq [simp]: "real_of_float (of_int z) = of_int z"
   by (cases z rule: int_diff_cases) (simp_all add: of_rat_diff)
 
 lemma Float_0_eq_0[simp]: "Float 0 e = 0"
   by transfer simp
 
 lemma real_of_float_power[simp]: "real_of_float (f^n) = real_of_float f^n" for f :: float
   by (induct n) simp_all
 
 lemma real_of_float_min: "real_of_float (min x y) = min (real_of_float x) (real_of_float y)"
   and real_of_float_max: "real_of_float (max x y) = max (real_of_float x) (real_of_float y)"
   for x y :: float
   by (simp_all add: min_def max_def)
 
 instance float :: unbounded_dense_linorder
 proof
   fix a b :: float
   show "\<exists>c. a < c"
     apply (intro exI[of _ "a + 1"])
     apply transfer
     apply simp
     done
   show "\<exists>c. c < a"
     apply (intro exI[of _ "a - 1"])
     apply transfer
     apply simp
     done
   show "\<exists>c. a < c \<and> c < b" if "a < b"
     apply (rule exI[of _ "(a + b) * Float 1 (- 1)"])
     using that
     apply transfer
     apply (simp add: powr_minus)
     done
 qed
 
 instantiation float :: lattice_ab_group_add
 begin
 
 definition inf_float :: "float \<Rightarrow> float \<Rightarrow> float"
   where "inf_float a b = min a b"
 
 definition sup_float :: "float \<Rightarrow> float \<Rightarrow> float"
   where "sup_float a b = max a b"
 
 instance
   by standard (transfer; simp add: inf_float_def sup_float_def real_of_float_min real_of_float_max)+
 
 end
 
 lemma float_numeral[simp]: "real_of_float (numeral x :: float) = numeral x"
   apply (induct x)
   apply simp
   apply (simp_all only: numeral_Bit0 numeral_Bit1 real_of_float_eq float_of_inverse
           plus_float.rep_eq one_float.rep_eq plus_float numeral_float one_float)
   done
 
 lemma transfer_numeral [transfer_rule]:
   "rel_fun (=) pcr_float (numeral :: _ \<Rightarrow> real) (numeral :: _ \<Rightarrow> float)"
   by (simp add: rel_fun_def float.pcr_cr_eq cr_float_def)
 
 lemma float_neg_numeral[simp]: "real_of_float (- numeral x :: float) = - numeral x"
   by simp
 
 lemma transfer_neg_numeral [transfer_rule]:
   "rel_fun (=) pcr_float (- numeral :: _ \<Rightarrow> real) (- numeral :: _ \<Rightarrow> float)"
   by (simp add: rel_fun_def float.pcr_cr_eq cr_float_def)
 
 lemma float_of_numeral: "numeral k = float_of (numeral k)"
   and float_of_neg_numeral: "- numeral k = float_of (- numeral k)"
   unfolding real_of_float_eq by simp_all
 
 
 subsection \<open>Quickcheck\<close>
 
 instantiation float :: exhaustive
 begin
 
 definition exhaustive_float where
   "exhaustive_float f d =
     Quickcheck_Exhaustive.exhaustive (\<lambda>x. Quickcheck_Exhaustive.exhaustive (\<lambda>y. f (Float x y)) d) d"
 
 instance ..
 
 end
 
 context
   includes term_syntax
 begin
 
 definition [code_unfold]:
   "valtermify_float x y = Code_Evaluation.valtermify Float {\<cdot>} x {\<cdot>} y"
 
 end
 
 instantiation float :: full_exhaustive
 begin
 
 definition
   "full_exhaustive_float f d =
     Quickcheck_Exhaustive.full_exhaustive
       (\<lambda>x. Quickcheck_Exhaustive.full_exhaustive (\<lambda>y. f (valtermify_float x y)) d) d"
 
 instance ..
 
 end
 
 instantiation float :: random
 begin
 
 definition "Quickcheck_Random.random i =
   scomp (Quickcheck_Random.random (2 ^ nat_of_natural i))
     (\<lambda>man. scomp (Quickcheck_Random.random i) (\<lambda>exp. Pair (valtermify_float man exp)))"
 
 instance ..
 
 end
 
 
 subsection \<open>Represent floats as unique mantissa and exponent\<close>
 
 lemma int_induct_abs[case_names less]:
   fixes j :: int
   assumes H: "\<And>n. (\<And>i. \<bar>i\<bar> < \<bar>n\<bar> \<Longrightarrow> P i) \<Longrightarrow> P n"
   shows "P j"
 proof (induct "nat \<bar>j\<bar>" arbitrary: j rule: less_induct)
   case less
   show ?case by (rule H[OF less]) simp
 qed
 
 lemma int_cancel_factors:
   fixes n :: int
   assumes "1 < r"
   shows "n = 0 \<or> (\<exists>k i. n = k * r ^ i \<and> \<not> r dvd k)"
 proof (induct n rule: int_induct_abs)
   case (less n)
   have "\<exists>k i. n = k * r ^ Suc i \<and> \<not> r dvd k" if "n \<noteq> 0" "n = m * r" for m
   proof -
     from that have "\<bar>m \<bar> < \<bar>n\<bar>"
       using \<open>1 < r\<close> by (simp add: abs_mult)
     from less[OF this] that show ?thesis by auto
   qed
   then show ?case
     by (metis dvd_def monoid_mult_class.mult.right_neutral mult.commute power_0)
 qed
 
 lemma mult_powr_eq_mult_powr_iff_asym:
   fixes m1 m2 e1 e2 :: int
   assumes m1: "\<not> 2 dvd m1"
     and "e1 \<le> e2"
   shows "m1 * 2 powr e1 = m2 * 2 powr e2 \<longleftrightarrow> m1 = m2 \<and> e1 = e2"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   show ?rhs if eq: ?lhs
   proof -
     have "m1 \<noteq> 0"
       using m1 unfolding dvd_def by auto
     from \<open>e1 \<le> e2\<close> eq have "m1 = m2 * 2 powr nat (e2 - e1)"
       by (simp add: powr_diff field_simps)
     also have "\<dots> = m2 * 2^nat (e2 - e1)"
       by (simp add: powr_realpow)
     finally have m1_eq: "m1 = m2 * 2^nat (e2 - e1)"
       by linarith
     with m1 have "m1 = m2"
       by (cases "nat (e2 - e1)") (auto simp add: dvd_def)
     then show ?thesis
       using eq \<open>m1 \<noteq> 0\<close> by (simp add: powr_inj)
   qed
   show ?lhs if ?rhs
     using that by simp
 qed
 
 lemma mult_powr_eq_mult_powr_iff:
   "\<not> 2 dvd m1 \<Longrightarrow> \<not> 2 dvd m2 \<Longrightarrow> m1 * 2 powr e1 = m2 * 2 powr e2 \<longleftrightarrow> m1 = m2 \<and> e1 = e2"
   for m1 m2 e1 e2 :: int
   using mult_powr_eq_mult_powr_iff_asym[of m1 e1 e2 m2]
   using mult_powr_eq_mult_powr_iff_asym[of m2 e2 e1 m1]
   by (cases e1 e2 rule: linorder_le_cases) auto
 
 lemma floatE_normed:
   assumes x: "x \<in> float"
   obtains (zero) "x = 0"
    | (powr) m e :: int where "x = m * 2 powr e" "\<not> 2 dvd m" "x \<noteq> 0"
 proof -
   have "\<exists>(m::int) (e::int). x = m * 2 powr e \<and> \<not> (2::int) dvd m" if "x \<noteq> 0"
   proof -
     from x obtain m e :: int where x: "x = m * 2 powr e"
       by (auto simp: float_def)
     with \<open>x \<noteq> 0\<close> int_cancel_factors[of 2 m] obtain k i where "m = k * 2 ^ i" "\<not> 2 dvd k"
       by auto
     with \<open>\<not> 2 dvd k\<close> x show ?thesis
       apply (rule_tac exI[of _ "k"])
       apply (rule_tac exI[of _ "e + int i"])
       apply (simp add: powr_add powr_realpow)
       done
   qed
   with that show thesis by blast
 qed
 
 lemma float_normed_cases:
   fixes f :: float
   obtains (zero) "f = 0"
    | (powr) m e :: int where "real_of_float f = m * 2 powr e" "\<not> 2 dvd m" "f \<noteq> 0"
 proof (atomize_elim, induct f)
   case (float_of y)
   then show ?case
     by (cases rule: floatE_normed) (auto simp: zero_float_def)
 qed
 
 definition mantissa :: "float \<Rightarrow> int"
   where "mantissa f =
     fst (SOME p::int \<times> int. (f = 0 \<and> fst p = 0 \<and> snd p = 0) \<or>
       (f \<noteq> 0 \<and> real_of_float f = real_of_int (fst p) * 2 powr real_of_int (snd p) \<and> \<not> 2 dvd fst p))"
 
 definition exponent :: "float \<Rightarrow> int"
   where "exponent f =
     snd (SOME p::int \<times> int. (f = 0 \<and> fst p = 0 \<and> snd p = 0) \<or>
       (f \<noteq> 0 \<and> real_of_float f = real_of_int (fst p) * 2 powr real_of_int (snd p) \<and> \<not> 2 dvd fst p))"
 
 lemma exponent_0[simp]: "exponent 0 = 0" (is ?E)
   and mantissa_0[simp]: "mantissa 0 = 0" (is ?M)
 proof -
   have "\<And>p::int \<times> int. fst p = 0 \<and> snd p = 0 \<longleftrightarrow> p = (0, 0)"
     by auto
   then show ?E ?M
     by (auto simp add: mantissa_def exponent_def zero_float_def)
 qed
 
 lemma mantissa_exponent: "real_of_float f = mantissa f * 2 powr exponent f" (is ?E)
   and mantissa_not_dvd: "f \<noteq> 0 \<Longrightarrow> \<not> 2 dvd mantissa f" (is "_ \<Longrightarrow> ?D")
 proof cases
   assume [simp]: "f \<noteq> 0"
   have "f = mantissa f * 2 powr exponent f \<and> \<not> 2 dvd mantissa f"
   proof (cases f rule: float_normed_cases)
     case zero
     then show ?thesis by simp
   next
     case (powr m e)
     then have "\<exists>p::int \<times> int. (f = 0 \<and> fst p = 0 \<and> snd p = 0) \<or>
       (f \<noteq> 0 \<and> real_of_float f = real_of_int (fst p) * 2 powr real_of_int (snd p) \<and> \<not> 2 dvd fst p)"
       by auto
     then show ?thesis
       unfolding exponent_def mantissa_def
       by (rule someI2_ex) simp
   qed
   then show ?E ?D by auto
 qed simp
 
 lemma mantissa_noteq_0: "f \<noteq> 0 \<Longrightarrow> mantissa f \<noteq> 0"
   using mantissa_not_dvd[of f] by auto
 
 lemma mantissa_eq_zero_iff: "mantissa x = 0 \<longleftrightarrow> x = 0"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   show ?rhs if ?lhs
   proof -
     from that have z: "0 = real_of_float x"
       using mantissa_exponent by simp
     show ?thesis
       by (simp add: zero_float_def z)
   qed
   show ?lhs if ?rhs
     using that by simp
 qed
 
 lemma mantissa_pos_iff: "0 < mantissa x \<longleftrightarrow> 0 < x"
   by (auto simp: mantissa_exponent algebra_split_simps)
 
 lemma mantissa_nonneg_iff: "0 \<le> mantissa x \<longleftrightarrow> 0 \<le> x"
   by (auto simp: mantissa_exponent algebra_split_simps)
 
 lemma mantissa_neg_iff: "0 > mantissa x \<longleftrightarrow> 0 > x"
   by (auto simp: mantissa_exponent algebra_split_simps)
 
 lemma
   fixes m e :: int
   defines "f \<equiv> float_of (m * 2 powr e)"
   assumes dvd: "\<not> 2 dvd m"
   shows mantissa_float: "mantissa f = m" (is "?M")
     and exponent_float: "m \<noteq> 0 \<Longrightarrow> exponent f = e" (is "_ \<Longrightarrow> ?E")
 proof cases
   assume "m = 0"
   with dvd show "mantissa f = m" by auto
 next
   assume "m \<noteq> 0"
   then have f_not_0: "f \<noteq> 0" by (simp add: f_def zero_float_def)
   from mantissa_exponent[of f] have "m * 2 powr e = mantissa f * 2 powr exponent f"
     by (auto simp add: f_def)
   then show ?M ?E
     using mantissa_not_dvd[OF f_not_0] dvd
     by (auto simp: mult_powr_eq_mult_powr_iff)
 qed
 
 
 subsection \<open>Compute arithmetic operations\<close>
 
 lemma Float_mantissa_exponent: "Float (mantissa f) (exponent f) = f"
   unfolding real_of_float_eq mantissa_exponent[of f] by simp
 
 lemma Float_cases [cases type: float]:
   fixes f :: float
   obtains (Float) m e :: int where "f = Float m e"
   using Float_mantissa_exponent[symmetric]
   by (atomize_elim) auto
 
 lemma denormalize_shift:
   assumes f_def: "f = Float m e"
     and not_0: "f \<noteq> 0"
   obtains i where "m = mantissa f * 2 ^ i" "e = exponent f - i"
 proof
   from mantissa_exponent[of f] f_def
   have "m * 2 powr e = mantissa f * 2 powr exponent f"
     by simp
   then have eq: "m = mantissa f * 2 powr (exponent f - e)"
     by (simp add: powr_diff field_simps)
   moreover
   have "e \<le> exponent f"
   proof (rule ccontr)
     assume "\<not> e \<le> exponent f"
     then have pos: "exponent f < e" by simp
     then have "2 powr (exponent f - e) = 2 powr - real_of_int (e - exponent f)"
       by simp
     also have "\<dots> = 1 / 2^nat (e - exponent f)"
       using pos by (simp flip: powr_realpow add: powr_diff)
     finally have "m * 2^nat (e - exponent f) = real_of_int (mantissa f)"
       using eq by simp
     then have "mantissa f = m * 2^nat (e - exponent f)"
       by linarith
     with \<open>exponent f < e\<close> have "2 dvd mantissa f"
       apply (intro dvdI[where k="m * 2^(nat (e-exponent f)) div 2"])
       apply (cases "nat (e - exponent f)")
       apply auto
       done
     then show False using mantissa_not_dvd[OF not_0] by simp
   qed
   ultimately have "real_of_int m = mantissa f * 2^nat (exponent f - e)"
     by (simp flip: powr_realpow)
   with \<open>e \<le> exponent f\<close>
   show "m = mantissa f * 2 ^ nat (exponent f - e)"
     by linarith
   show "e = exponent f - nat (exponent f - e)"
     using \<open>e \<le> exponent f\<close> by auto
 qed
 
 context
 begin
 
 qualified lemma compute_float_zero[code_unfold, code]: "0 = Float 0 0"
   by transfer simp
 
 qualified lemma compute_float_one[code_unfold, code]: "1 = Float 1 0"
   by transfer simp
 
 lift_definition normfloat :: "float \<Rightarrow> float" is "\<lambda>x. x" .
 lemma normloat_id[simp]: "normfloat x = x" by transfer rule
 
 qualified lemma compute_normfloat[code]:
   "normfloat (Float m e) =
     (if m mod 2 = 0 \<and> m \<noteq> 0 then normfloat (Float (m div 2) (e + 1))
      else if m = 0 then 0 else Float m e)"
   by transfer (auto simp add: powr_add zmod_eq_0_iff)
 
 qualified lemma compute_float_numeral[code_abbrev]: "Float (numeral k) 0 = numeral k"
   by transfer simp
 
 qualified lemma compute_float_neg_numeral[code_abbrev]: "Float (- numeral k) 0 = - numeral k"
   by transfer simp
 
 qualified lemma compute_float_uminus[code]: "- Float m1 e1 = Float (- m1) e1"
   by transfer simp
 
 qualified lemma compute_float_times[code]: "Float m1 e1 * Float m2 e2 = Float (m1 * m2) (e1 + e2)"
   by transfer (simp add: field_simps powr_add)
 
 qualified lemma compute_float_plus[code]:
   "Float m1 e1 + Float m2 e2 =
     (if m1 = 0 then Float m2 e2
      else if m2 = 0 then Float m1 e1
      else if e1 \<le> e2 then Float (m1 + m2 * 2^nat (e2 - e1)) e1
      else Float (m2 + m1 * 2^nat (e1 - e2)) e2)"
   by transfer (simp add: field_simps powr_realpow[symmetric] powr_diff)
 
 qualified lemma compute_float_minus[code]: "f - g = f + (-g)" for f g :: float
   by simp
 
 qualified lemma compute_float_sgn[code]:
   "sgn (Float m1 e1) = (if 0 < m1 then 1 else if m1 < 0 then -1 else 0)"
   by transfer (simp add: sgn_mult)
 
 lift_definition is_float_pos :: "float \<Rightarrow> bool" is "(<) 0 :: real \<Rightarrow> bool" .
 
 qualified lemma compute_is_float_pos[code]: "is_float_pos (Float m e) \<longleftrightarrow> 0 < m"
   by transfer (auto simp add: zero_less_mult_iff not_le[symmetric, of _ 0])
 
 lift_definition is_float_nonneg :: "float \<Rightarrow> bool" is "(\<le>) 0 :: real \<Rightarrow> bool" .
 
 qualified lemma compute_is_float_nonneg[code]: "is_float_nonneg (Float m e) \<longleftrightarrow> 0 \<le> m"
   by transfer (auto simp add: zero_le_mult_iff not_less[symmetric, of _ 0])
 
 lift_definition is_float_zero :: "float \<Rightarrow> bool"  is "(=) 0 :: real \<Rightarrow> bool" .
 
 qualified lemma compute_is_float_zero[code]: "is_float_zero (Float m e) \<longleftrightarrow> 0 = m"
   by transfer (auto simp add: is_float_zero_def)
 
 qualified lemma compute_float_abs[code]: "\<bar>Float m e\<bar> = Float \<bar>m\<bar> e"
   by transfer (simp add: abs_mult)
 
 qualified lemma compute_float_eq[code]: "equal_class.equal f g = is_float_zero (f - g)"
   by transfer simp
 
 end
 
 
 subsection \<open>Lemmas for types \<^typ>\<open>real\<close>, \<^typ>\<open>nat\<close>, \<^typ>\<open>int\<close>\<close>
 
 lemmas real_of_ints =
   of_int_add
   of_int_minus
   of_int_diff
   of_int_mult
   of_int_power
   of_int_numeral of_int_neg_numeral
 
 lemmas int_of_reals = real_of_ints[symmetric]
 
 
 subsection \<open>Rounding Real Numbers\<close>
 
 definition round_down :: "int \<Rightarrow> real \<Rightarrow> real"
   where "round_down prec x = \<lfloor>x * 2 powr prec\<rfloor> * 2 powr -prec"
 
 definition round_up :: "int \<Rightarrow> real \<Rightarrow> real"
   where "round_up prec x = \<lceil>x * 2 powr prec\<rceil> * 2 powr -prec"
 
 lemma round_down_float[simp]: "round_down prec x \<in> float"
   unfolding round_down_def
   by (auto intro!: times_float simp flip: of_int_minus)
 
 lemma round_up_float[simp]: "round_up prec x \<in> float"
   unfolding round_up_def
   by (auto intro!: times_float simp flip: of_int_minus)
 
 lemma round_up: "x \<le> round_up prec x"
   by (simp add: powr_minus_divide le_divide_eq round_up_def ceiling_correct)
 
 lemma round_down: "round_down prec x \<le> x"
   by (simp add: powr_minus_divide divide_le_eq round_down_def)
 
 lemma round_up_0[simp]: "round_up p 0 = 0"
   unfolding round_up_def by simp
 
 lemma round_down_0[simp]: "round_down p 0 = 0"
   unfolding round_down_def by simp
 
 lemma round_up_diff_round_down: "round_up prec x - round_down prec x \<le> 2 powr -prec"
 proof -
   have "round_up prec x - round_down prec x = (\<lceil>x * 2 powr prec\<rceil> - \<lfloor>x * 2 powr prec\<rfloor>) * 2 powr -prec"
     by (simp add: round_up_def round_down_def field_simps)
   also have "\<dots> \<le> 1 * 2 powr -prec"
     by (rule mult_mono)
       (auto simp flip: of_int_diff simp: ceiling_diff_floor_le_1)
   finally show ?thesis by simp
 qed
 
 lemma round_down_shift: "round_down p (x * 2 powr k) = 2 powr k * round_down (p + k) x"
   unfolding round_down_def
   by (simp add: powr_add powr_mult field_simps powr_diff)
     (simp flip: powr_add)
 
 lemma round_up_shift: "round_up p (x * 2 powr k) = 2 powr k * round_up (p + k) x"
   unfolding round_up_def
   by (simp add: powr_add powr_mult field_simps powr_diff)
     (simp flip: powr_add)
 
 lemma round_up_uminus_eq: "round_up p (-x) = - round_down p x"
   and round_down_uminus_eq: "round_down p (-x) = - round_up p x"
   by (auto simp: round_up_def round_down_def ceiling_def)
 
 lemma round_up_mono: "x \<le> y \<Longrightarrow> round_up p x \<le> round_up p y"
   by (auto intro!: ceiling_mono simp: round_up_def)
 
 lemma round_up_le1:
   assumes "x \<le> 1" "prec \<ge> 0"
   shows "round_up prec x \<le> 1"
 proof -
   have "real_of_int \<lceil>x * 2 powr prec\<rceil> \<le> real_of_int \<lceil>2 powr real_of_int prec\<rceil>"
     using assms by (auto intro!: ceiling_mono)
   also have "\<dots> = 2 powr prec" using assms by (auto simp: powr_int intro!: exI[where x="2^nat prec"])
   finally show ?thesis
     by (simp add: round_up_def) (simp add: powr_minus inverse_eq_divide)
 qed
 
 lemma round_up_less1:
   assumes "x < 1 / 2" "p > 0"
   shows "round_up p x < 1"
 proof -
   have "x * 2 powr p < 1 / 2 * 2 powr p"
     using assms by simp
   also have "\<dots> \<le> 2 powr p - 1" using \<open>p > 0\<close>
     by (auto simp: powr_diff powr_int field_simps self_le_power)
   finally show ?thesis using \<open>p > 0\<close>
     by (simp add: round_up_def field_simps powr_minus powr_int ceiling_less_iff)
 qed
 
 lemma round_down_ge1:
   assumes x: "x \<ge> 1"
   assumes prec: "p \<ge> - log 2 x"
   shows "1 \<le> round_down p x"
 proof cases
   assume nonneg: "0 \<le> p"
   have "2 powr p = real_of_int \<lfloor>2 powr real_of_int p\<rfloor>"
     using nonneg by (auto simp: powr_int)
   also have "\<dots> \<le> real_of_int \<lfloor>x * 2 powr p\<rfloor>"
     using assms by (auto intro!: floor_mono)
   finally show ?thesis
     by (simp add: round_down_def) (simp add: powr_minus inverse_eq_divide)
 next
   assume neg: "\<not> 0 \<le> p"
   have "x = 2 powr (log 2 x)"
     using x by simp
   also have "2 powr (log 2 x) \<ge> 2 powr - p"
     using prec by auto
   finally have x_le: "x \<ge> 2 powr -p" .
 
   from neg have "2 powr real_of_int p \<le> 2 powr 0"
     by (intro powr_mono) auto
   also have "\<dots> \<le> \<lfloor>2 powr 0::real\<rfloor>" by simp
   also have "\<dots> \<le> \<lfloor>x * 2 powr (real_of_int p)\<rfloor>"
     unfolding of_int_le_iff
     using x x_le by (intro floor_mono) (simp add: powr_minus_divide field_simps)
   finally show ?thesis
     using prec x
     by (simp add: round_down_def powr_minus_divide pos_le_divide_eq)
 qed
 
 lemma round_up_le0: "x \<le> 0 \<Longrightarrow> round_up p x \<le> 0"
   unfolding round_up_def
   by (auto simp: field_simps mult_le_0_iff zero_le_mult_iff)
 
 
 subsection \<open>Rounding Floats\<close>
 
 definition div_twopow :: "int \<Rightarrow> nat \<Rightarrow> int"
   where [simp]: "div_twopow x n = x div (2 ^ n)"
 
 definition mod_twopow :: "int \<Rightarrow> nat \<Rightarrow> int"
   where [simp]: "mod_twopow x n = x mod (2 ^ n)"
 
 lemma compute_div_twopow[code]:
   "div_twopow x n = (if x = 0 \<or> x = -1 \<or> n = 0 then x else div_twopow (x div 2) (n - 1))"
   by (cases n) (auto simp: zdiv_zmult2_eq div_eq_minus1)
 
 lemma compute_mod_twopow[code]:
   "mod_twopow x n = (if n = 0 then 0 else x mod 2 + 2 * mod_twopow (x div 2) (n - 1))"
   by (cases n) (auto simp: zmod_zmult2_eq)
 
 lift_definition float_up :: "int \<Rightarrow> float \<Rightarrow> float" is round_up by simp
 declare float_up.rep_eq[simp]
 
 lemma round_up_correct: "round_up e f - f \<in> {0..2 powr -e}"
   unfolding atLeastAtMost_iff
 proof
   have "round_up e f - f \<le> round_up e f - round_down e f"
     using round_down by simp
   also have "\<dots> \<le> 2 powr -e"
     using round_up_diff_round_down by simp
   finally show "round_up e f - f \<le> 2 powr - (real_of_int e)"
     by simp
 qed (simp add: algebra_simps round_up)
 
 lemma float_up_correct: "real_of_float (float_up e f) - real_of_float f \<in> {0..2 powr -e}"
   by transfer (rule round_up_correct)
 
 lift_definition float_down :: "int \<Rightarrow> float \<Rightarrow> float" is round_down by simp
 declare float_down.rep_eq[simp]
 
 lemma round_down_correct: "f - (round_down e f) \<in> {0..2 powr -e}"
   unfolding atLeastAtMost_iff
 proof
   have "f - round_down e f \<le> round_up e f - round_down e f"
     using round_up by simp
   also have "\<dots> \<le> 2 powr -e"
     using round_up_diff_round_down by simp
   finally show "f - round_down e f \<le> 2 powr - (real_of_int e)"
     by simp
 qed (simp add: algebra_simps round_down)
 
 lemma float_down_correct: "real_of_float f - real_of_float (float_down e f) \<in> {0..2 powr -e}"
   by transfer (rule round_down_correct)
 
 context
 begin
 
 qualified lemma compute_float_down[code]:
   "float_down p (Float m e) =
     (if p + e < 0 then Float (div_twopow m (nat (-(p + e)))) (-p) else Float m e)"
 proof (cases "p + e < 0")
   case True
   then have "real_of_int ((2::int) ^ nat (-(p + e))) = 2 powr (-(p + e))"
     using powr_realpow[of 2 "nat (-(p + e))"] by simp
   also have "\<dots> = 1 / 2 powr p / 2 powr e"
     unfolding powr_minus_divide of_int_minus by (simp add: powr_add)
   finally show ?thesis
     using \<open>p + e < 0\<close>
     apply transfer
     apply (simp add: round_down_def field_simps flip: floor_divide_of_int_eq)
     apply (metis (no_types, hide_lams) Float.rep_eq
       add.inverse_inverse compute_real_of_float diff_minus_eq_add
       floor_divide_of_int_eq int_of_reals(1) linorder_not_le
       minus_add_distrib of_int_eq_numeral_power_cancel_iff powr_add)
     done
 next
   case False
   then have r: "real_of_int e + real_of_int p = real (nat (e + p))"
     by simp
   have r: "\<lfloor>(m * 2 powr e) * 2 powr real_of_int p\<rfloor> = (m * 2 powr e) * 2 powr real_of_int p"
     by (auto intro: exI[where x="m*2^nat (e+p)"]
         simp add: ac_simps powr_add[symmetric] r powr_realpow)
   with \<open>\<not> p + e < 0\<close> show ?thesis
     by transfer (auto simp add: round_down_def field_simps powr_add powr_minus)
 qed
 
 lemma abs_round_down_le: "\<bar>f - (round_down e f)\<bar> \<le> 2 powr -e"
   using round_down_correct[of f e] by simp
 
 lemma abs_round_up_le: "\<bar>f - (round_up e f)\<bar> \<le> 2 powr -e"
   using round_up_correct[of e f] by simp
 
 lemma round_down_nonneg: "0 \<le> s \<Longrightarrow> 0 \<le> round_down p s"
   by (auto simp: round_down_def)
 
 lemma ceil_divide_floor_conv:
   assumes "b \<noteq> 0"
   shows "\<lceil>real_of_int a / real_of_int b\<rceil> =
     (if b dvd a then a div b else \<lfloor>real_of_int a / real_of_int b\<rfloor> + 1)"
 proof (cases "b dvd a")
   case True
   then show ?thesis
     by (simp add: ceiling_def floor_divide_of_int_eq dvd_neg_div
              flip: of_int_minus divide_minus_left)
 next
   case False
   then have "a mod b \<noteq> 0"
     by auto
   then have ne: "real_of_int (a mod b) / real_of_int b \<noteq> 0"
     using \<open>b \<noteq> 0\<close> by auto
   have "\<lceil>real_of_int a / real_of_int b\<rceil> = \<lfloor>real_of_int a / real_of_int b\<rfloor> + 1"
     apply (rule ceiling_eq)
     apply (auto simp flip: floor_divide_of_int_eq)
   proof -
     have "real_of_int \<lfloor>real_of_int a / real_of_int b\<rfloor> \<le> real_of_int a / real_of_int b"
       by simp
     moreover have "real_of_int \<lfloor>real_of_int a / real_of_int b\<rfloor> \<noteq> real_of_int a / real_of_int b"
       apply (subst (2) real_of_int_div_aux)
       unfolding floor_divide_of_int_eq
       using ne \<open>b \<noteq> 0\<close> apply auto
       done
     ultimately show "real_of_int \<lfloor>real_of_int a / real_of_int b\<rfloor> < real_of_int a / real_of_int b" by arith
   qed
   then show ?thesis
     using \<open>\<not> b dvd a\<close> by simp
 qed
 
 qualified lemma compute_float_up[code]: "float_up p x = - float_down p (-x)"
   by transfer (simp add: round_down_uminus_eq)
 
 end
 
 
 lemma bitlen_Float:
   fixes m e
   defines [THEN meta_eq_to_obj_eq]: "f \<equiv> Float m e"
   shows "bitlen \<bar>mantissa f\<bar> + exponent f = (if m = 0 then 0 else bitlen \<bar>m\<bar> + e)"
 proof (cases "m = 0")
   case True
   then show ?thesis by (simp add: f_def bitlen_alt_def)
 next
   case False
   then have "f \<noteq> 0"
     unfolding real_of_float_eq by (simp add: f_def)
   then have "mantissa f \<noteq> 0"
     by (simp add: mantissa_eq_zero_iff)
   moreover
   obtain i where "m = mantissa f * 2 ^ i" "e = exponent f - int i"
     by (rule f_def[THEN denormalize_shift, OF \<open>f \<noteq> 0\<close>])
   ultimately show ?thesis by (simp add: abs_mult)
 qed
 
 lemma float_gt1_scale:
   assumes "1 \<le> Float m e"
   shows "0 \<le> e + (bitlen m - 1)"
 proof -
   have "0 < Float m e" using assms by auto
   then have "0 < m" using powr_gt_zero[of 2 e]
     by (auto simp: zero_less_mult_iff)
   then have "m \<noteq> 0" by auto
   show ?thesis
   proof (cases "0 \<le> e")
     case True
     then show ?thesis
       using \<open>0 < m\<close> by (simp add: bitlen_alt_def)
   next
     case False
     have "(1::int) < 2" by simp
     let ?S = "2^(nat (-e))"
     have "inverse (2 ^ nat (- e)) = 2 powr e"
       using assms False powr_realpow[of 2 "nat (-e)"]
       by (auto simp: powr_minus field_simps)
     then have "1 \<le> real_of_int m * inverse ?S"
       using assms False powr_realpow[of 2 "nat (-e)"]
       by (auto simp: powr_minus)
     then have "1 * ?S \<le> real_of_int m * inverse ?S * ?S"
       by (rule mult_right_mono) auto
     then have "?S \<le> real_of_int m"
       unfolding mult.assoc by auto
     then have "?S \<le> m"
       unfolding of_int_le_iff[symmetric] by auto
     from this bitlen_bounds[OF \<open>0 < m\<close>, THEN conjunct2]
     have "nat (-e) < (nat (bitlen m))"
       unfolding power_strict_increasing_iff[OF \<open>1 < 2\<close>, symmetric]
       by (rule order_le_less_trans)
     then have "-e < bitlen m"
       using False by auto
     then show ?thesis
       by auto
   qed
 qed
 
 
 subsection \<open>Truncating Real Numbers\<close>
 
 definition truncate_down::"nat \<Rightarrow> real \<Rightarrow> real"
   where "truncate_down prec x = round_down (prec - \<lfloor>log 2 \<bar>x\<bar>\<rfloor>) x"
 
 lemma truncate_down: "truncate_down prec x \<le> x"
   using round_down by (simp add: truncate_down_def)
 
 lemma truncate_down_le: "x \<le> y \<Longrightarrow> truncate_down prec x \<le> y"
   by (rule order_trans[OF truncate_down])
 
 lemma truncate_down_zero[simp]: "truncate_down prec 0 = 0"
   by (simp add: truncate_down_def)
 
 lemma truncate_down_float[simp]: "truncate_down p x \<in> float"
   by (auto simp: truncate_down_def)
 
 definition truncate_up::"nat \<Rightarrow> real \<Rightarrow> real"
   where "truncate_up prec x = round_up (prec - \<lfloor>log 2 \<bar>x\<bar>\<rfloor>) x"
 
 lemma truncate_up: "x \<le> truncate_up prec x"
   using round_up by (simp add: truncate_up_def)
 
 lemma truncate_up_le: "x \<le> y \<Longrightarrow> x \<le> truncate_up prec y"
   by (rule order_trans[OF _ truncate_up])
 
 lemma truncate_up_zero[simp]: "truncate_up prec 0 = 0"
   by (simp add: truncate_up_def)
 
 lemma truncate_up_uminus_eq: "truncate_up prec (-x) = - truncate_down prec x"
   and truncate_down_uminus_eq: "truncate_down prec (-x) = - truncate_up prec x"
   by (auto simp: truncate_up_def round_up_def truncate_down_def round_down_def ceiling_def)
 
 lemma truncate_up_float[simp]: "truncate_up p x \<in> float"
   by (auto simp: truncate_up_def)
 
 lemma mult_powr_eq: "0 < b \<Longrightarrow> b \<noteq> 1 \<Longrightarrow> 0 < x \<Longrightarrow> x * b powr y = b powr (y + log b x)"
   by (simp_all add: powr_add)
 
 lemma truncate_down_pos:
   assumes "x > 0"
   shows "truncate_down p x > 0"
 proof -
   have "0 \<le> log 2 x - real_of_int \<lfloor>log 2 x\<rfloor>"
     by (simp add: algebra_simps)
   with assms
   show ?thesis
     apply (auto simp: truncate_down_def round_down_def mult_powr_eq
       intro!: ge_one_powr_ge_zero mult_pos_pos)
     by linarith
 qed
 
 lemma truncate_down_nonneg: "0 \<le> y \<Longrightarrow> 0 \<le> truncate_down prec y"
   by (auto simp: truncate_down_def round_down_def)
 
 lemma truncate_down_ge1: "1 \<le> x \<Longrightarrow> 1 \<le> truncate_down p x"
   apply (auto simp: truncate_down_def algebra_simps intro!: round_down_ge1)
   apply linarith
   done
 
 lemma truncate_up_nonpos: "x \<le> 0 \<Longrightarrow> truncate_up prec x \<le> 0"
   by (auto simp: truncate_up_def round_up_def intro!: mult_nonpos_nonneg)
 
 lemma truncate_up_le1:
   assumes "x \<le> 1"
   shows "truncate_up p x \<le> 1"
 proof -
   consider "x \<le> 0" | "x > 0"
     by arith
   then show ?thesis
   proof cases
     case 1
     with truncate_up_nonpos[OF this, of p] show ?thesis
       by simp
   next
     case 2
     then have le: "\<lfloor>log 2 \<bar>x\<bar>\<rfloor> \<le> 0"
       using assms by (auto simp: log_less_iff)
     from assms have "0 \<le> int p" by simp
     from add_mono[OF this le]
     show ?thesis
       using assms by (simp add: truncate_up_def round_up_le1 add_mono)
   qed
 qed
 
 lemma truncate_down_shift_int:
   "truncate_down p (x * 2 powr real_of_int k) = truncate_down p x * 2 powr k"
   by (cases "x = 0")
     (simp_all add: algebra_simps abs_mult log_mult truncate_down_def
       round_down_shift[of _ _ k, simplified])
 
 lemma truncate_down_shift_nat: "truncate_down p (x * 2 powr real k) = truncate_down p x * 2 powr k"
   by (metis of_int_of_nat_eq truncate_down_shift_int)
 
 lemma truncate_up_shift_int: "truncate_up p (x * 2 powr real_of_int k) = truncate_up p x * 2 powr k"
   by (cases "x = 0")
     (simp_all add: algebra_simps abs_mult log_mult truncate_up_def
       round_up_shift[of _ _ k, simplified])
 
 lemma truncate_up_shift_nat: "truncate_up p (x * 2 powr real k) = truncate_up p x * 2 powr k"
   by (metis of_int_of_nat_eq truncate_up_shift_int)
 
 
 subsection \<open>Truncating Floats\<close>
 
 lift_definition float_round_up :: "nat \<Rightarrow> float \<Rightarrow> float" is truncate_up
   by (simp add: truncate_up_def)
 
 lemma float_round_up: "real_of_float x \<le> real_of_float (float_round_up prec x)"
   using truncate_up by transfer simp
 
 lemma float_round_up_zero[simp]: "float_round_up prec 0 = 0"
   by transfer simp
 
 lift_definition float_round_down :: "nat \<Rightarrow> float \<Rightarrow> float" is truncate_down
   by (simp add: truncate_down_def)
 
 lemma float_round_down: "real_of_float (float_round_down prec x) \<le> real_of_float x"
   using truncate_down by transfer simp
 
 lemma float_round_down_zero[simp]: "float_round_down prec 0 = 0"
   by transfer simp
 
 lemmas float_round_up_le = order_trans[OF _ float_round_up]
   and float_round_down_le = order_trans[OF float_round_down]
 
 lemma minus_float_round_up_eq: "- float_round_up prec x = float_round_down prec (- x)"
   and minus_float_round_down_eq: "- float_round_down prec x = float_round_up prec (- x)"
   by (transfer; simp add: truncate_down_uminus_eq truncate_up_uminus_eq)+
 
 context
 begin
 
 qualified lemma compute_float_round_down[code]:
   "float_round_down prec (Float m e) =
     (let d = bitlen \<bar>m\<bar> - int prec - 1 in
       if 0 < d then Float (div_twopow m (nat d)) (e + d)
       else Float m e)"
   using Float.compute_float_down[of "Suc prec - bitlen \<bar>m\<bar> - e" m e, symmetric]
   by transfer
     (simp add: field_simps abs_mult log_mult bitlen_alt_def truncate_down_def
       cong del: if_weak_cong)
 
 qualified lemma compute_float_round_up[code]:
   "float_round_up prec x = - float_round_down prec (-x)"
   by transfer (simp add: truncate_down_uminus_eq)
 
 end
 
 lemma truncate_up_nonneg_mono:
   assumes "0 \<le> x" "x \<le> y"
   shows "truncate_up prec x \<le> truncate_up prec y"
 proof -
   consider "\<lfloor>log 2 x\<rfloor> = \<lfloor>log 2 y\<rfloor>" | "\<lfloor>log 2 x\<rfloor> \<noteq> \<lfloor>log 2 y\<rfloor>" "0 < x" | "x \<le> 0"
     by arith
   then show ?thesis
   proof cases
     case 1
     then show ?thesis
       using assms
       by (auto simp: truncate_up_def round_up_def intro!: ceiling_mono)
   next
     case 2
     from assms \<open>0 < x\<close> have "log 2 x \<le> log 2 y"
       by auto
     with \<open>\<lfloor>log 2 x\<rfloor> \<noteq> \<lfloor>log 2 y\<rfloor>\<close>
     have logless: "log 2 x < log 2 y"
       by linarith
     have flogless: "\<lfloor>log 2 x\<rfloor> < \<lfloor>log 2 y\<rfloor>"
       using \<open>\<lfloor>log 2 x\<rfloor> \<noteq> \<lfloor>log 2 y\<rfloor>\<close> \<open>log 2 x \<le> log 2 y\<close> by linarith
     have "truncate_up prec x =
       real_of_int \<lceil>x * 2 powr real_of_int (int prec - \<lfloor>log 2 x\<rfloor> )\<rceil> * 2 powr - real_of_int (int prec - \<lfloor>log 2 x\<rfloor>)"
       using assms by (simp add: truncate_up_def round_up_def)
     also have "\<lceil>x * 2 powr real_of_int (int prec - \<lfloor>log 2 x\<rfloor>)\<rceil> \<le> (2 ^ (Suc prec))"
     proof (simp only: ceiling_le_iff)
       have "x * 2 powr real_of_int (int prec - \<lfloor>log 2 x\<rfloor>) \<le>
         x * (2 powr real (Suc prec) / (2 powr log 2 x))"
         using real_of_int_floor_add_one_ge[of "log 2 x"] assms
         by (auto simp: algebra_simps simp flip: powr_diff intro!: mult_left_mono)
       then show "x * 2 powr real_of_int (int prec - \<lfloor>log 2 x\<rfloor>) \<le> real_of_int ((2::int) ^ (Suc prec))"
         using \<open>0 < x\<close> by (simp add: powr_realpow powr_add)
     qed
     then have "real_of_int \<lceil>x * 2 powr real_of_int (int prec - \<lfloor>log 2 x\<rfloor>)\<rceil> \<le> 2 powr int (Suc prec)"
       by (auto simp: powr_realpow powr_add)
         (metis power_Suc of_int_le_numeral_power_cancel_iff)
     also
     have "2 powr - real_of_int (int prec - \<lfloor>log 2 x\<rfloor>) \<le> 2 powr - real_of_int (int prec - \<lfloor>log 2 y\<rfloor> + 1)"
       using logless flogless by (auto intro!: floor_mono)
     also have "2 powr real_of_int (int (Suc prec)) \<le>
         2 powr (log 2 y + real_of_int (int prec - \<lfloor>log 2 y\<rfloor> + 1))"
       using assms \<open>0 < x\<close>
       by (auto simp: algebra_simps)
     finally have "truncate_up prec x \<le>
         2 powr (log 2 y + real_of_int (int prec - \<lfloor>log 2 y\<rfloor> + 1)) * 2 powr - real_of_int (int prec - \<lfloor>log 2 y\<rfloor> + 1)"
       by simp
     also have "\<dots> = 2 powr (log 2 y + real_of_int (int prec - \<lfloor>log 2 y\<rfloor>) - real_of_int (int prec - \<lfloor>log 2 y\<rfloor>))"
       by (subst powr_add[symmetric]) simp
     also have "\<dots> = y"
       using \<open>0 < x\<close> assms
       by (simp add: powr_add)
     also have "\<dots> \<le> truncate_up prec y"
       by (rule truncate_up)
     finally show ?thesis .
   next
     case 3
     then show ?thesis
       using assms
       by (auto intro!: truncate_up_le)
   qed
 qed
 
 lemma truncate_up_switch_sign_mono:
   assumes "x \<le> 0" "0 \<le> y"
   shows "truncate_up prec x \<le> truncate_up prec y"
 proof -
   note truncate_up_nonpos[OF \<open>x \<le> 0\<close>]
   also note truncate_up_le[OF \<open>0 \<le> y\<close>]
   finally show ?thesis .
 qed
 
 lemma truncate_down_switch_sign_mono:
   assumes "x \<le> 0"
     and "0 \<le> y"
     and "x \<le> y"
   shows "truncate_down prec x \<le> truncate_down prec y"
 proof -
   note truncate_down_le[OF \<open>x \<le> 0\<close>]
   also note truncate_down_nonneg[OF \<open>0 \<le> y\<close>]
   finally show ?thesis .
 qed
 
 lemma truncate_down_nonneg_mono:
   assumes "0 \<le> x" "x \<le> y"
   shows "truncate_down prec x \<le> truncate_down prec y"
 proof -
   consider "x \<le> 0" | "\<lfloor>log 2 \<bar>x\<bar>\<rfloor> = \<lfloor>log 2 \<bar>y\<bar>\<rfloor>" |
     "0 < x" "\<lfloor>log 2 \<bar>x\<bar>\<rfloor> \<noteq> \<lfloor>log 2 \<bar>y\<bar>\<rfloor>"
     by arith
   then show ?thesis
   proof cases
     case 1
     with assms have "x = 0" "0 \<le> y" by simp_all
     then show ?thesis
       by (auto intro!: truncate_down_nonneg)
   next
     case 2
     then show ?thesis
       using assms
       by (auto simp: truncate_down_def round_down_def intro!: floor_mono)
   next
     case 3
     from \<open>0 < x\<close> have "log 2 x \<le> log 2 y" "0 < y" "0 \<le> y"
       using assms by auto
     with \<open>\<lfloor>log 2 \<bar>x\<bar>\<rfloor> \<noteq> \<lfloor>log 2 \<bar>y\<bar>\<rfloor>\<close>
     have logless: "log 2 x < log 2 y" and flogless: "\<lfloor>log 2 x\<rfloor> < \<lfloor>log 2 y\<rfloor>"
       unfolding atomize_conj abs_of_pos[OF \<open>0 < x\<close>] abs_of_pos[OF \<open>0 < y\<close>]
       by (metis floor_less_cancel linorder_cases not_le)
     have "2 powr prec \<le> y * 2 powr real prec / (2 powr log 2 y)"
       using \<open>0 < y\<close> by simp
     also have "\<dots> \<le> y * 2 powr real (Suc prec) / (2 powr (real_of_int \<lfloor>log 2 y\<rfloor> + 1))"
       using \<open>0 \<le> y\<close> \<open>0 \<le> x\<close> assms(2)
       by (auto intro!: powr_mono divide_left_mono
           simp: of_nat_diff powr_add powr_diff)
     also have "\<dots> = y * 2 powr real (Suc prec) / (2 powr real_of_int \<lfloor>log 2 y\<rfloor> * 2)"
       by (auto simp: powr_add)
     finally have "(2 ^ prec) \<le> \<lfloor>y * 2 powr real_of_int (int (Suc prec) - \<lfloor>log 2 \<bar>y\<bar>\<rfloor> - 1)\<rfloor>"
       using \<open>0 \<le> y\<close>
       by (auto simp: powr_diff le_floor_iff powr_realpow powr_add)
     then have "(2 ^ (prec)) * 2 powr - real_of_int (int prec - \<lfloor>log 2 \<bar>y\<bar>\<rfloor>) \<le> truncate_down prec y"
       by (auto simp: truncate_down_def round_down_def)
     moreover have "x \<le> (2 ^ prec) * 2 powr - real_of_int (int prec - \<lfloor>log 2 \<bar>y\<bar>\<rfloor>)"
     proof -
       have "x = 2 powr (log 2 \<bar>x\<bar>)" using \<open>0 < x\<close> by simp
       also have "\<dots> \<le> (2 ^ (Suc prec )) * 2 powr - real_of_int (int prec - \<lfloor>log 2 \<bar>x\<bar>\<rfloor>)"
         using real_of_int_floor_add_one_ge[of "log 2 \<bar>x\<bar>"] \<open>0 < x\<close>
         by (auto simp flip: powr_realpow powr_add simp: algebra_simps powr_mult_base le_powr_iff)
       also
       have "2 powr - real_of_int (int prec - \<lfloor>log 2 \<bar>x\<bar>\<rfloor>) \<le> 2 powr - real_of_int (int prec - \<lfloor>log 2 \<bar>y\<bar>\<rfloor> + 1)"
         using logless flogless \<open>x > 0\<close> \<open>y > 0\<close>
         by (auto intro!: floor_mono)
       finally show ?thesis
         by (auto simp flip: powr_realpow simp: powr_diff assms of_nat_diff)
     qed
     ultimately show ?thesis
       by (metis dual_order.trans truncate_down)
   qed
 qed
 
 lemma truncate_down_eq_truncate_up: "truncate_down p x = - truncate_up p (-x)"
   and truncate_up_eq_truncate_down: "truncate_up p x = - truncate_down p (-x)"
   by (auto simp: truncate_up_uminus_eq truncate_down_uminus_eq)
 
 lemma truncate_down_mono: "x \<le> y \<Longrightarrow> truncate_down p x \<le> truncate_down p y"
   apply (cases "0 \<le> x")
   apply (rule truncate_down_nonneg_mono, assumption+)
   apply (simp add: truncate_down_eq_truncate_up)
   apply (cases "0 \<le> y")
   apply (auto intro: truncate_up_nonneg_mono truncate_up_switch_sign_mono)
   done
 
 lemma truncate_up_mono: "x \<le> y \<Longrightarrow> truncate_up p x \<le> truncate_up p y"
   by (simp add: truncate_up_eq_truncate_down truncate_down_mono)
 
 lemma truncate_up_nonneg: "0 \<le> truncate_up p x" if "0 \<le> x"
   by (simp add: that truncate_up_le)
 
 lemma truncate_up_pos: "0 < truncate_up p x" if "0 < x"
   by (meson less_le_trans that truncate_up)
 
 lemma truncate_up_less_zero_iff[simp]: "truncate_up p x < 0 \<longleftrightarrow> x < 0"
 proof -
   have f1: "\<forall>n r. truncate_up n r + truncate_down n (- 1 * r) = 0"
     by (simp add: truncate_down_uminus_eq)
   have f2: "(\<forall>v0 v1. truncate_up v0 v1 + truncate_down v0 (- 1 * v1) = 0) = (\<forall>v0 v1. truncate_up v0 v1 = - 1 * truncate_down v0 (- 1 * v1))"
     by (auto simp: truncate_up_eq_truncate_down)
   have f3: "\<forall>x1. ((0::real) < x1) = (\<not> x1 \<le> 0)"
     by fastforce
   have "(- 1 * x \<le> 0) = (0 \<le> x)"
     by force
   then have "0 \<le> x \<or> \<not> truncate_down p (- 1 * x) \<le> 0"
     using f3 by (meson truncate_down_pos)
   then have "(0 \<le> truncate_up p x) \<noteq> (\<not> 0 \<le> x)"
     using f2 f1 truncate_up_nonneg by force
   then show ?thesis
     by linarith
 qed
 
 lemma truncate_up_nonneg_iff[simp]: "truncate_up p x \<ge> 0 \<longleftrightarrow> x \<ge> 0"
   using truncate_up_less_zero_iff[of p x] truncate_up_nonneg[of x]
   by linarith
 
 lemma truncate_down_less_zero_iff[simp]: "truncate_down p x < 0 \<longleftrightarrow> x < 0"
   by (metis le_less_trans not_less_iff_gr_or_eq truncate_down truncate_down_pos truncate_down_zero)
 
 lemma truncate_down_nonneg_iff[simp]: "truncate_down p x \<ge> 0 \<longleftrightarrow> x \<ge> 0"
   using truncate_down_less_zero_iff[of p x] truncate_down_nonneg[of x p]
   by linarith
 
 lemma truncate_down_eq_zero_iff[simp]: "truncate_down prec x = 0 \<longleftrightarrow> x = 0"
   by (metis not_less_iff_gr_or_eq truncate_down_less_zero_iff truncate_down_pos truncate_down_zero)
 
 lemma truncate_up_eq_zero_iff[simp]: "truncate_up prec x = 0 \<longleftrightarrow> x = 0"
   by (metis not_less_iff_gr_or_eq truncate_up_less_zero_iff truncate_up_pos truncate_up_zero)
 
 
 subsection \<open>Approximation of positive rationals\<close>
 
 lemma div_mult_twopow_eq: "a div ((2::nat) ^ n) div b = a div (b * 2 ^ n)" for a b :: nat
   by (cases "b = 0") (simp_all add: div_mult2_eq[symmetric] ac_simps)
 
 lemma real_div_nat_eq_floor_of_divide: "a div b = real_of_int \<lfloor>a / b\<rfloor>" for a b :: nat
   by (simp add: floor_divide_of_nat_eq [of a b])
 
 definition "rat_precision prec x y =
   (let d = bitlen x - bitlen y
    in int prec - d + (if Float (abs x) 0 < Float (abs y) d then 1 else 0))"
 
 lemma floor_log_divide_eq:
   assumes "i > 0" "j > 0" "p > 1"
   shows "\<lfloor>log p (i / j)\<rfloor> = floor (log p i) - floor (log p j) -
     (if i \<ge> j * p powr (floor (log p i) - floor (log p j)) then 0 else 1)"
 proof -
   let ?l = "log p"
   let ?fl = "\<lambda>x. floor (?l x)"
   have "\<lfloor>?l (i / j)\<rfloor> = \<lfloor>?l i - ?l j\<rfloor>" using assms
     by (auto simp: log_divide)
   also have "\<dots> = floor (real_of_int (?fl i - ?fl j) + (?l i - ?fl i - (?l j - ?fl j)))"
     (is "_ = floor (_ + ?r)")
     by (simp add: algebra_simps)
   also note floor_add2
   also note \<open>p > 1\<close>
   note powr = powr_le_cancel_iff[symmetric, OF \<open>1 < p\<close>, THEN iffD2]
   note powr_strict = powr_less_cancel_iff[symmetric, OF \<open>1 < p\<close>, THEN iffD2]
   have "floor ?r = (if i \<ge> j * p powr (?fl i - ?fl j) then 0 else -1)" (is "_ = ?if")
     using assms
     by (linarith |
       auto
         intro!: floor_eq2
         intro: powr_strict powr
         simp: powr_diff powr_add field_split_simps algebra_simps)+
   finally
   show ?thesis by simp
 qed
 
 lemma truncate_down_rat_precision:
     "truncate_down prec (real x / real y) = round_down (rat_precision prec x y) (real x / real y)"
   and truncate_up_rat_precision:
     "truncate_up prec (real x / real y) = round_up (rat_precision prec x y) (real x / real y)"
   unfolding truncate_down_def truncate_up_def rat_precision_def
   by (cases x; cases y) (auto simp: floor_log_divide_eq algebra_simps bitlen_alt_def)
 
 lift_definition lapprox_posrat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> float"
   is "\<lambda>prec (x::nat) (y::nat). truncate_down prec (x / y)"
   by simp
 
 context
 begin
 
 qualified lemma compute_lapprox_posrat[code]:
   "lapprox_posrat prec x y =
    (let
       l = rat_precision prec x y;
       d = if 0 \<le> l then x * 2^nat l div y else x div 2^nat (- l) div y
     in normfloat (Float d (- l)))"
     unfolding div_mult_twopow_eq
     by transfer
       (simp add: round_down_def powr_int real_div_nat_eq_floor_of_divide field_simps Let_def
         truncate_down_rat_precision del: two_powr_minus_int_float)
 
 end
 
 lift_definition rapprox_posrat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> float"
   is "\<lambda>prec (x::nat) (y::nat). truncate_up prec (x / y)"
   by simp
 
 context
 begin
 
 qualified lemma compute_rapprox_posrat[code]:
   fixes prec x y
   defines "l \<equiv> rat_precision prec x y"
   shows "rapprox_posrat prec x y =
    (let
       l = l;
       (r, s) = if 0 \<le> l then (x * 2^nat l, y) else (x, y * 2^nat(-l));
       d = r div s;
       m = r mod s
     in normfloat (Float (d + (if m = 0 \<or> y = 0 then 0 else 1)) (- l)))"
 proof (cases "y = 0")
   assume "y = 0"
   then show ?thesis by transfer simp
 next
   assume "y \<noteq> 0"
   show ?thesis
   proof (cases "0 \<le> l")
     case True
     define x' where "x' = x * 2 ^ nat l"
     have "int x * 2 ^ nat l = x'"
       by (simp add: x'_def)
     moreover have "real x * 2 powr l = real x'"
       by (simp flip: powr_realpow add: \<open>0 \<le> l\<close> x'_def)
     ultimately show ?thesis
       using ceil_divide_floor_conv[of y x'] powr_realpow[of 2 "nat l"] \<open>0 \<le> l\<close> \<open>y \<noteq> 0\<close>
         l_def[symmetric, THEN meta_eq_to_obj_eq]
       apply transfer
       apply (auto simp add: round_up_def truncate_up_rat_precision)
       apply (metis dvd_triv_left of_nat_dvd_iff)
       apply (metis floor_divide_of_int_eq of_int_of_nat_eq)
       done
    next
     case False
     define y' where "y' = y * 2 ^ nat (- l)"
     from \<open>y \<noteq> 0\<close> have "y' \<noteq> 0" by (simp add: y'_def)
     have "int y * 2 ^ nat (- l) = y'"
       by (simp add: y'_def)
     moreover have "real x * real_of_int (2::int) powr real_of_int l / real y = x / real y'"
       using \<open>\<not> 0 \<le> l\<close> by (simp flip: powr_realpow add: powr_minus y'_def field_simps)
     ultimately show ?thesis
       using ceil_divide_floor_conv[of y' x] \<open>\<not> 0 \<le> l\<close> \<open>y' \<noteq> 0\<close> \<open>y \<noteq> 0\<close>
         l_def[symmetric, THEN meta_eq_to_obj_eq]
       apply transfer
       apply (auto simp add: round_up_def ceil_divide_floor_conv truncate_up_rat_precision)
       apply (metis dvd_triv_left of_nat_dvd_iff)
       apply (metis floor_divide_of_int_eq of_int_of_nat_eq)
       done
   qed
 qed
 
 end
 
 lemma rat_precision_pos:
   assumes "0 \<le> x"
     and "0 < y"
     and "2 * x < y"
   shows "rat_precision n (int x) (int y) > 0"
 proof -
   have "0 < x \<Longrightarrow> log 2 x + 1 = log 2 (2 * x)"
     by (simp add: log_mult)
   then have "bitlen (int x) < bitlen (int y)"
     using assms
     by (simp add: bitlen_alt_def)
       (auto intro!: floor_mono simp add: one_add_floor)
   then show ?thesis
     using assms
     by (auto intro!: pos_add_strict simp add: field_simps rat_precision_def)
 qed
 
 lemma rapprox_posrat_less1:
   "0 \<le> x \<Longrightarrow> 0 < y \<Longrightarrow> 2 * x < y \<Longrightarrow> real_of_float (rapprox_posrat n x y) < 1"
   by transfer (simp add: rat_precision_pos round_up_less1 truncate_up_rat_precision)
 
 lift_definition lapprox_rat :: "nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> float" is
   "\<lambda>prec (x::int) (y::int). truncate_down prec (x / y)"
   by simp
 
 context
 begin
 
 qualified lemma compute_lapprox_rat[code]:
   "lapprox_rat prec x y =
    (if y = 0 then 0
     else if 0 \<le> x then
      (if 0 < y then lapprox_posrat prec (nat x) (nat y)
       else - (rapprox_posrat prec (nat x) (nat (-y))))
       else
        (if 0 < y
         then - (rapprox_posrat prec (nat (-x)) (nat y))
         else lapprox_posrat prec (nat (-x)) (nat (-y))))"
   by transfer (simp add: truncate_up_uminus_eq)
 
 lift_definition rapprox_rat :: "nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> float" is
   "\<lambda>prec (x::int) (y::int). truncate_up prec (x / y)"
   by simp
 
 lemma "rapprox_rat = rapprox_posrat"
   by transfer auto
 
 lemma "lapprox_rat = lapprox_posrat"
   by transfer auto
 
 qualified lemma compute_rapprox_rat[code]:
   "rapprox_rat prec x y = - lapprox_rat prec (-x) y"
   by transfer (simp add: truncate_down_uminus_eq)
 
 qualified lemma compute_truncate_down[code]:
   "truncate_down p (Ratreal r) = (let (a, b) = quotient_of r in lapprox_rat p a b)"
   by transfer (auto split: prod.split simp: of_rat_divide dest!: quotient_of_div)
 
 qualified lemma compute_truncate_up[code]:
   "truncate_up p (Ratreal r) = (let (a, b) = quotient_of r in rapprox_rat p a b)"
   by transfer (auto split: prod.split simp:  of_rat_divide dest!: quotient_of_div)
 
 end
 
 
 subsection \<open>Division\<close>
 
 definition "real_divl prec a b = truncate_down prec (a / b)"
 
 definition "real_divr prec a b = truncate_up prec (a / b)"
 
 lift_definition float_divl :: "nat \<Rightarrow> float \<Rightarrow> float \<Rightarrow> float" is real_divl
   by (simp add: real_divl_def)
 
 context
 begin
 
 qualified lemma compute_float_divl[code]:
   "float_divl prec (Float m1 s1) (Float m2 s2) = lapprox_rat prec m1 m2 * Float 1 (s1 - s2)"
   apply transfer
   unfolding real_divl_def of_int_1 mult_1 truncate_down_shift_int[symmetric]
   apply (simp add: powr_diff powr_minus)
   done
 
 lift_definition float_divr :: "nat \<Rightarrow> float \<Rightarrow> float \<Rightarrow> float" is real_divr
   by (simp add: real_divr_def)
 
 qualified lemma compute_float_divr[code]:
   "float_divr prec x y = - float_divl prec (-x) y"
   by transfer (simp add: real_divr_def real_divl_def truncate_down_uminus_eq)
 
 end
 
 
 subsection \<open>Approximate Addition\<close>
 
 definition "plus_down prec x y = truncate_down prec (x + y)"
 
 definition "plus_up prec x y = truncate_up prec (x + y)"
 
 lemma float_plus_down_float[intro, simp]: "x \<in> float \<Longrightarrow> y \<in> float \<Longrightarrow> plus_down p x y \<in> float"
   by (simp add: plus_down_def)
 
 lemma float_plus_up_float[intro, simp]: "x \<in> float \<Longrightarrow> y \<in> float \<Longrightarrow> plus_up p x y \<in> float"
   by (simp add: plus_up_def)
 
 lift_definition float_plus_down :: "nat \<Rightarrow> float \<Rightarrow> float \<Rightarrow> float" is plus_down ..
 
 lift_definition float_plus_up :: "nat \<Rightarrow> float \<Rightarrow> float \<Rightarrow> float" is plus_up ..
 
 lemma plus_down: "plus_down prec x y \<le> x + y"
   and plus_up: "x + y \<le> plus_up prec x y"
   by (auto simp: plus_down_def truncate_down plus_up_def truncate_up)
 
 lemma float_plus_down: "real_of_float (float_plus_down prec x y) \<le> x + y"
   and float_plus_up: "x + y \<le> real_of_float (float_plus_up prec x y)"
   by (transfer; rule plus_down plus_up)+
 
 lemmas plus_down_le = order_trans[OF plus_down]
   and plus_up_le = order_trans[OF _ plus_up]
   and float_plus_down_le = order_trans[OF float_plus_down]
   and float_plus_up_le = order_trans[OF _ float_plus_up]
 
 lemma compute_plus_up[code]: "plus_up p x y = - plus_down p (-x) (-y)"
   using truncate_down_uminus_eq[of p "x + y"]
   by (auto simp: plus_down_def plus_up_def)
 
 lemma truncate_down_log2_eqI:
   assumes "\<lfloor>log 2 \<bar>x\<bar>\<rfloor> = \<lfloor>log 2 \<bar>y\<bar>\<rfloor>"
   assumes "\<lfloor>x * 2 powr (p - \<lfloor>log 2 \<bar>x\<bar>\<rfloor>)\<rfloor> = \<lfloor>y * 2 powr (p - \<lfloor>log 2 \<bar>x\<bar>\<rfloor>)\<rfloor>"
   shows "truncate_down p x = truncate_down p y"
   using assms by (auto simp: truncate_down_def round_down_def)
 
 lemma sum_neq_zeroI:
   "\<bar>a\<bar> \<ge> k \<Longrightarrow> \<bar>b\<bar> < k \<Longrightarrow> a + b \<noteq> 0"
   "\<bar>a\<bar> > k \<Longrightarrow> \<bar>b\<bar> \<le> k \<Longrightarrow> a + b \<noteq> 0"
   for a k :: real
   by auto
 
 lemma abs_real_le_2_powr_bitlen[simp]: "\<bar>real_of_int m2\<bar> < 2 powr real_of_int (bitlen \<bar>m2\<bar>)"
 proof (cases "m2 = 0")
   case True
   then show ?thesis by simp
 next
   case False
   then have "\<bar>m2\<bar> < 2 ^ nat (bitlen \<bar>m2\<bar>)"
     using bitlen_bounds[of "\<bar>m2\<bar>"]
     by (auto simp: powr_add bitlen_nonneg)
   then show ?thesis
     by (metis bitlen_nonneg powr_int of_int_abs of_int_less_numeral_power_cancel_iff
         zero_less_numeral)
 qed
 
 lemma floor_sum_times_2_powr_sgn_eq:
   fixes ai p q :: int
     and a b :: real
   assumes "a * 2 powr p = ai"
     and b_le_1: "\<bar>b * 2 powr (p + 1)\<bar> \<le> 1"
     and leqp: "q \<le> p"
   shows "\<lfloor>(a + b) * 2 powr q\<rfloor> = \<lfloor>(2 * ai + sgn b) * 2 powr (q - p - 1)\<rfloor>"
 proof -
   consider "b = 0" | "b > 0" | "b < 0" by arith
   then show ?thesis
   proof cases
     case 1
     then show ?thesis
       by (simp flip: assms(1) powr_add add: algebra_simps powr_mult_base)
   next
     case 2
     then have "b * 2 powr p < \<bar>b * 2 powr (p + 1)\<bar>"
       by simp
     also note b_le_1
     finally have b_less_1: "b * 2 powr real_of_int p < 1" .
 
     from b_less_1 \<open>b > 0\<close> have floor_eq: "\<lfloor>b * 2 powr real_of_int p\<rfloor> = 0" "\<lfloor>sgn b / 2\<rfloor> = 0"
       by (simp_all add: floor_eq_iff)
 
     have "\<lfloor>(a + b) * 2 powr q\<rfloor> = \<lfloor>(a + b) * 2 powr p * 2 powr (q - p)\<rfloor>"
       by (simp add: algebra_simps flip: powr_realpow powr_add)
     also have "\<dots> = \<lfloor>(ai + b * 2 powr p) * 2 powr (q - p)\<rfloor>"
       by (simp add: assms algebra_simps)
     also have "\<dots> = \<lfloor>(ai + b * 2 powr p) / real_of_int ((2::int) ^ nat (p - q))\<rfloor>"
       using assms
       by (simp add: algebra_simps divide_powr_uminus flip: powr_realpow powr_add)
     also have "\<dots> = \<lfloor>ai / real_of_int ((2::int) ^ nat (p - q))\<rfloor>"
       by (simp del: of_int_power add: floor_divide_real_eq_div floor_eq)
     finally have "\<lfloor>(a + b) * 2 powr real_of_int q\<rfloor> = \<lfloor>real_of_int ai / real_of_int ((2::int) ^ nat (p - q))\<rfloor>" .
     moreover
     have "\<lfloor>(2 * ai + (sgn b)) * 2 powr (real_of_int (q - p) - 1)\<rfloor> =
         \<lfloor>real_of_int ai / real_of_int ((2::int) ^ nat (p - q))\<rfloor>"
     proof -
       have "\<lfloor>(2 * ai + sgn b) * 2 powr (real_of_int (q - p) - 1)\<rfloor> = \<lfloor>(ai + sgn b / 2) * 2 powr (q - p)\<rfloor>"
         by (subst powr_diff) (simp add: field_simps)
       also have "\<dots> = \<lfloor>(ai + sgn b / 2) / real_of_int ((2::int) ^ nat (p - q))\<rfloor>"
         using leqp by (simp flip: powr_realpow add: powr_diff)
       also have "\<dots> = \<lfloor>ai / real_of_int ((2::int) ^ nat (p - q))\<rfloor>"
         by (simp del: of_int_power add: floor_divide_real_eq_div floor_eq)
       finally show ?thesis .
     qed
     ultimately show ?thesis by simp
   next
     case 3
     then have floor_eq: "\<lfloor>b * 2 powr (real_of_int p + 1)\<rfloor> = -1"
       using b_le_1
       by (auto simp: floor_eq_iff algebra_simps pos_divide_le_eq[symmetric] abs_if divide_powr_uminus
         intro!: mult_neg_pos split: if_split_asm)
     have "\<lfloor>(a + b) * 2 powr q\<rfloor> = \<lfloor>(2*a + 2*b) * 2 powr p * 2 powr (q - p - 1)\<rfloor>"
       by (simp add: algebra_simps powr_mult_base flip: powr_realpow powr_add)
     also have "\<dots> = \<lfloor>(2 * (a * 2 powr p) + 2 * b * 2 powr p) * 2 powr (q - p - 1)\<rfloor>"
       by (simp add: algebra_simps)
     also have "\<dots> = \<lfloor>(2 * ai + b * 2 powr (p + 1)) / 2 powr (1 - q + p)\<rfloor>"
       using assms by (simp add: algebra_simps powr_mult_base divide_powr_uminus)
     also have "\<dots> = \<lfloor>(2 * ai + b * 2 powr (p + 1)) / real_of_int ((2::int) ^ nat (p - q + 1))\<rfloor>"
       using assms by (simp add: algebra_simps flip: powr_realpow)
     also have "\<dots> = \<lfloor>(2 * ai - 1) / real_of_int ((2::int) ^ nat (p - q + 1))\<rfloor>"
       using \<open>b < 0\<close> assms
       by (simp add: floor_divide_of_int_eq floor_eq floor_divide_real_eq_div
         del: of_int_mult of_int_power of_int_diff)
     also have "\<dots> = \<lfloor>(2 * ai - 1) * 2 powr (q - p - 1)\<rfloor>"
       using assms by (simp add: algebra_simps divide_powr_uminus flip: powr_realpow)
     finally show ?thesis
       using \<open>b < 0\<close> by simp
   qed
 qed
 
 lemma log2_abs_int_add_less_half_sgn_eq:
   fixes ai :: int
     and b :: real
   assumes "\<bar>b\<bar> \<le> 1/2"
     and "ai \<noteq> 0"
   shows "\<lfloor>log 2 \<bar>real_of_int ai + b\<bar>\<rfloor> = \<lfloor>log 2 \<bar>ai + sgn b / 2\<bar>\<rfloor>"
 proof (cases "b = 0")
   case True
   then show ?thesis by simp
 next
   case False
   define k where "k = \<lfloor>log 2 \<bar>ai\<bar>\<rfloor>"
   then have "\<lfloor>log 2 \<bar>ai\<bar>\<rfloor> = k"
     by simp
   then have k: "2 powr k \<le> \<bar>ai\<bar>" "\<bar>ai\<bar> < 2 powr (k + 1)"
     by (simp_all add: floor_log_eq_powr_iff \<open>ai \<noteq> 0\<close>)
   have "k \<ge> 0"
     using assms by (auto simp: k_def)
   define r where "r = \<bar>ai\<bar> - 2 ^ nat k"
   have r: "0 \<le> r" "r < 2 powr k"
     using \<open>k \<ge> 0\<close> k
     by (auto simp: r_def k_def algebra_simps powr_add abs_if powr_int)
   then have "r \<le> (2::int) ^ nat k - 1"
     using \<open>k \<ge> 0\<close> by (auto simp: powr_int)
   from this[simplified of_int_le_iff[symmetric]] \<open>0 \<le> k\<close>
   have r_le: "r \<le> 2 powr k - 1"
     by (auto simp: algebra_simps powr_int)
       (metis of_int_1 of_int_add of_int_le_numeral_power_cancel_iff)
 
   have "\<bar>ai\<bar> = 2 powr k + r"
     using \<open>k \<ge> 0\<close> by (auto simp: k_def r_def simp flip: powr_realpow)
 
   have pos: "\<bar>b\<bar> < 1 \<Longrightarrow> 0 < 2 powr k + (r + b)" for b :: real
     using \<open>0 \<le> k\<close> \<open>ai \<noteq> 0\<close>
     by (auto simp add: r_def powr_realpow[symmetric] abs_if sgn_if algebra_simps
       split: if_split_asm)
   have less: "\<bar>sgn ai * b\<bar> < 1"
     and less': "\<bar>sgn (sgn ai * b) / 2\<bar> < 1"
     using \<open>\<bar>b\<bar> \<le> _\<close> by (auto simp: abs_if sgn_if split: if_split_asm)
 
   have floor_eq: "\<And>b::real. \<bar>b\<bar> \<le> 1 / 2 \<Longrightarrow>
       \<lfloor>log 2 (1 + (r + b) / 2 powr k)\<rfloor> = (if r = 0 \<and> b < 0 then -1 else 0)"
     using \<open>k \<ge> 0\<close> r r_le
     by (auto simp: floor_log_eq_powr_iff powr_minus_divide field_simps sgn_if)
 
   from \<open>real_of_int \<bar>ai\<bar> = _\<close> have "\<bar>ai + b\<bar> = 2 powr k + (r + sgn ai * b)"
     using \<open>\<bar>b\<bar> \<le> _\<close> \<open>0 \<le> k\<close> r
     by (auto simp add: sgn_if abs_if)
   also have "\<lfloor>log 2 \<dots>\<rfloor> = \<lfloor>log 2 (2 powr k + r + sgn (sgn ai * b) / 2)\<rfloor>"
   proof -
     have "2 powr k + (r + (sgn ai) * b) = 2 powr k * (1 + (r + sgn ai * b) / 2 powr k)"
       by (simp add: field_simps)
     also have "\<lfloor>log 2 \<dots>\<rfloor> = k + \<lfloor>log 2 (1 + (r + sgn ai * b) / 2 powr k)\<rfloor>"
       using pos[OF less]
       by (subst log_mult) (simp_all add: log_mult powr_mult field_simps)
     also
     let ?if = "if r = 0 \<and> sgn ai * b < 0 then -1 else 0"
     have "\<lfloor>log 2 (1 + (r + sgn ai * b) / 2 powr k)\<rfloor> = ?if"
       using \<open>\<bar>b\<bar> \<le> _\<close>
       by (intro floor_eq) (auto simp: abs_mult sgn_if)
     also
     have "\<dots> = \<lfloor>log 2 (1 + (r + sgn (sgn ai * b) / 2) / 2 powr k)\<rfloor>"
       by (subst floor_eq) (auto simp: sgn_if)
     also have "k + \<dots> = \<lfloor>log 2 (2 powr k * (1 + (r + sgn (sgn ai * b) / 2) / 2 powr k))\<rfloor>"
       unfolding int_add_floor
       using pos[OF less'] \<open>\<bar>b\<bar> \<le> _\<close>
       by (simp add: field_simps add_log_eq_powr del: floor_add2)
     also have "2 powr k * (1 + (r + sgn (sgn ai * b) / 2) / 2 powr k) =
         2 powr k + r + sgn (sgn ai * b) / 2"
       by (simp add: sgn_if field_simps)
     finally show ?thesis .
   qed
   also have "2 powr k + r + sgn (sgn ai * b) / 2 = \<bar>ai + sgn b / 2\<bar>"
     unfolding \<open>real_of_int \<bar>ai\<bar> = _\<close>[symmetric] using \<open>ai \<noteq> 0\<close>
     by (auto simp: abs_if sgn_if algebra_simps)
   finally show ?thesis .
 qed
 
 context
 begin
 
 qualified lemma compute_far_float_plus_down:
   fixes m1 e1 m2 e2 :: int
     and p :: nat
   defines "k1 \<equiv> Suc p - nat (bitlen \<bar>m1\<bar>)"
   assumes H: "bitlen \<bar>m2\<bar> \<le> e1 - e2 - k1 - 2" "m1 \<noteq> 0" "m2 \<noteq> 0" "e1 \<ge> e2"
   shows "float_plus_down p (Float m1 e1) (Float m2 e2) =
     float_round_down p (Float (m1 * 2 ^ (Suc (Suc k1)) + sgn m2) (e1 - int k1 - 2))"
 proof -
   let ?a = "real_of_float (Float m1 e1)"
   let ?b = "real_of_float (Float m2 e2)"
   let ?sum = "?a + ?b"
   let ?shift = "real_of_int e2 - real_of_int e1 + real k1 + 1"
   let ?m1 = "m1 * 2 ^ Suc k1"
   let ?m2 = "m2 * 2 powr ?shift"
   let ?m2' = "sgn m2 / 2"
   let ?e = "e1 - int k1 - 1"
 
   have sum_eq: "?sum = (?m1 + ?m2) * 2 powr ?e"
     by (auto simp flip: powr_add powr_mult powr_realpow simp: powr_mult_base algebra_simps)
 
   have "\<bar>?m2\<bar> * 2 < 2 powr (bitlen \<bar>m2\<bar> + ?shift + 1)"
     by (auto simp: field_simps powr_add powr_mult_base powr_diff abs_mult)
   also have "\<dots> \<le> 2 powr 0"
     using H by (intro powr_mono) auto
   finally have abs_m2_less_half: "\<bar>?m2\<bar> < 1 / 2"
     by simp
 
   then have "\<bar>real_of_int m2\<bar> < 2 powr -(?shift + 1)"
     unfolding powr_minus_divide by (auto simp: bitlen_alt_def field_simps powr_mult_base abs_mult)
   also have "\<dots> \<le> 2 powr real_of_int (e1 - e2 - 2)"
     by simp
   finally have b_less_quarter: "\<bar>?b\<bar> < 1/4 * 2 powr real_of_int e1"
     by (simp add: powr_add field_simps powr_diff abs_mult)
   also have "1/4 < \<bar>real_of_int m1\<bar> / 2" using \<open>m1 \<noteq> 0\<close> by simp
   finally have b_less_half_a: "\<bar>?b\<bar> < 1/2 * \<bar>?a\<bar>"
     by (simp add: algebra_simps powr_mult_base abs_mult)
   then have a_half_less_sum: "\<bar>?a\<bar> / 2 < \<bar>?sum\<bar>"
     by (auto simp: field_simps abs_if split: if_split_asm)
 
   from b_less_half_a have "\<bar>?b\<bar> < \<bar>?a\<bar>" "\<bar>?b\<bar> \<le> \<bar>?a\<bar>"
     by simp_all
 
   have "\<bar>real_of_float (Float m1 e1)\<bar> \<ge> 1/4 * 2 powr real_of_int e1"
     using \<open>m1 \<noteq> 0\<close>
     by (auto simp: powr_add powr_int bitlen_nonneg divide_right_mono abs_mult)
   then have "?sum \<noteq> 0" using b_less_quarter
     by (rule sum_neq_zeroI)
   then have "?m1 + ?m2 \<noteq> 0"
     unfolding sum_eq by (simp add: abs_mult zero_less_mult_iff)
 
   have "\<bar>real_of_int ?m1\<bar> \<ge> 2 ^ Suc k1" "\<bar>?m2'\<bar> < 2 ^ Suc k1"
     using \<open>m1 \<noteq> 0\<close> \<open>m2 \<noteq> 0\<close> by (auto simp: sgn_if less_1_mult abs_mult simp del: power.simps)
   then have sum'_nz: "?m1 + ?m2' \<noteq> 0"
     by (intro sum_neq_zeroI)
 
   have "\<lfloor>log 2 \<bar>real_of_float (Float m1 e1) + real_of_float (Float m2 e2)\<bar>\<rfloor> = \<lfloor>log 2 \<bar>?m1 + ?m2\<bar>\<rfloor> + ?e"
     using \<open>?m1 + ?m2 \<noteq> 0\<close>
     unfolding floor_add[symmetric] sum_eq
     by (simp add: abs_mult log_mult) linarith
   also have "\<lfloor>log 2 \<bar>?m1 + ?m2\<bar>\<rfloor> = \<lfloor>log 2 \<bar>?m1 + sgn (real_of_int m2 * 2 powr ?shift) / 2\<bar>\<rfloor>"
     using abs_m2_less_half \<open>m1 \<noteq> 0\<close>
     by (intro log2_abs_int_add_less_half_sgn_eq) (auto simp: abs_mult)
   also have "sgn (real_of_int m2 * 2 powr ?shift) = sgn m2"
     by (auto simp: sgn_if zero_less_mult_iff less_not_sym)
   also
   have "\<bar>?m1 + ?m2'\<bar> * 2 powr ?e = \<bar>?m1 * 2 + sgn m2\<bar> * 2 powr (?e - 1)"
     by (auto simp: field_simps powr_minus[symmetric] powr_diff powr_mult_base)
   then have "\<lfloor>log 2 \<bar>?m1 + ?m2'\<bar>\<rfloor> + ?e = \<lfloor>log 2 \<bar>real_of_float (Float (?m1 * 2 + sgn m2) (?e - 1))\<bar>\<rfloor>"
     using \<open>?m1 + ?m2' \<noteq> 0\<close>
     unfolding floor_add_int
     by (simp add: log_add_eq_powr abs_mult_pos del: floor_add2)
   finally
   have "\<lfloor>log 2 \<bar>?sum\<bar>\<rfloor> = \<lfloor>log 2 \<bar>real_of_float (Float (?m1*2 + sgn m2) (?e - 1))\<bar>\<rfloor>" .
   then have "plus_down p (Float m1 e1) (Float m2 e2) =
       truncate_down p (Float (?m1*2 + sgn m2) (?e - 1))"
     unfolding plus_down_def
   proof (rule truncate_down_log2_eqI)
     let ?f = "(int p - \<lfloor>log 2 \<bar>real_of_float (Float m1 e1) + real_of_float (Float m2 e2)\<bar>\<rfloor>)"
     let ?ai = "m1 * 2 ^ (Suc k1)"
     have "\<lfloor>(?a + ?b) * 2 powr real_of_int ?f\<rfloor> = \<lfloor>(real_of_int (2 * ?ai) + sgn ?b) * 2 powr real_of_int (?f - - ?e - 1)\<rfloor>"
     proof (rule floor_sum_times_2_powr_sgn_eq)
       show "?a * 2 powr real_of_int (-?e) = real_of_int ?ai"
         by (simp add: powr_add powr_realpow[symmetric] powr_diff)
       show "\<bar>?b * 2 powr real_of_int (-?e + 1)\<bar> \<le> 1"
         using abs_m2_less_half
         by (simp add: abs_mult powr_add[symmetric] algebra_simps powr_mult_base)
     next
       have "e1 + \<lfloor>log 2 \<bar>real_of_int m1\<bar>\<rfloor> - 1 = \<lfloor>log 2 \<bar>?a\<bar>\<rfloor> - 1"
         using \<open>m1 \<noteq> 0\<close>
         by (simp add: int_add_floor algebra_simps log_mult abs_mult del: floor_add2)
       also have "\<dots> \<le> \<lfloor>log 2 \<bar>?a + ?b\<bar>\<rfloor>"
         using a_half_less_sum \<open>m1 \<noteq> 0\<close> \<open>?sum \<noteq> 0\<close>
         unfolding floor_diff_of_int[symmetric]
         by (auto simp add: log_minus_eq_powr powr_minus_divide intro!: floor_mono)
       finally
       have "int p - \<lfloor>log 2 \<bar>?a + ?b\<bar>\<rfloor> \<le> p - (bitlen \<bar>m1\<bar>) - e1 + 2"
         by (auto simp: algebra_simps bitlen_alt_def \<open>m1 \<noteq> 0\<close>)
       also have "\<dots> \<le> - ?e"
         using bitlen_nonneg[of "\<bar>m1\<bar>"] by (simp add: k1_def)
       finally show "?f \<le> - ?e" by simp
     qed
     also have "sgn ?b = sgn m2"
       using powr_gt_zero[of 2 e2]
       by (auto simp add: sgn_if zero_less_mult_iff simp del: powr_gt_zero)
     also have "\<lfloor>(real_of_int (2 * ?m1) + real_of_int (sgn m2)) * 2 powr real_of_int (?f - - ?e - 1)\<rfloor> =
         \<lfloor>Float (?m1 * 2 + sgn m2) (?e - 1) * 2 powr ?f\<rfloor>"
       by (simp flip: powr_add powr_realpow add: algebra_simps)
     finally
     show "\<lfloor>(?a + ?b) * 2 powr ?f\<rfloor> = \<lfloor>real_of_float (Float (?m1 * 2 + sgn m2) (?e - 1)) * 2 powr ?f\<rfloor>" .
   qed
   then show ?thesis
     by transfer (simp add: plus_down_def ac_simps Let_def)
 qed
 
 lemma compute_float_plus_down_naive[code]: "float_plus_down p x y = float_round_down p (x + y)"
   by transfer (auto simp: plus_down_def)
 
 qualified lemma compute_float_plus_down[code]:
   fixes p::nat and m1 e1 m2 e2::int
   shows "float_plus_down p (Float m1 e1) (Float m2 e2) =
     (if m1 = 0 then float_round_down p (Float m2 e2)
     else if m2 = 0 then float_round_down p (Float m1 e1)
     else
       (if e1 \<ge> e2 then
         (let k1 = Suc p - nat (bitlen \<bar>m1\<bar>) in
           if bitlen \<bar>m2\<bar> > e1 - e2 - k1 - 2
           then float_round_down p ((Float m1 e1) + (Float m2 e2))
           else float_round_down p (Float (m1 * 2 ^ (Suc (Suc k1)) + sgn m2) (e1 - int k1 - 2)))
     else float_plus_down p (Float m2 e2) (Float m1 e1)))"
 proof -
   {
     assume "bitlen \<bar>m2\<bar> \<le> e1 - e2 - (Suc p - nat (bitlen \<bar>m1\<bar>)) - 2" "m1 \<noteq> 0" "m2 \<noteq> 0" "e1 \<ge> e2"
     note compute_far_float_plus_down[OF this]
   }
   then show ?thesis
     by transfer (simp add: Let_def plus_down_def ac_simps)
 qed
 
 qualified lemma compute_float_plus_up[code]: "float_plus_up p x y = - float_plus_down p (-x) (-y)"
   using truncate_down_uminus_eq[of p "x + y"]
   by transfer (simp add: plus_down_def plus_up_def ac_simps)
 
 lemma mantissa_zero: "mantissa 0 = 0"
   by (fact mantissa_0)
 
 qualified lemma compute_float_less[code]: "a < b \<longleftrightarrow> is_float_pos (float_plus_down 0 b (- a))"
   using truncate_down[of 0 "b - a"] truncate_down_pos[of "b - a" 0]
   by transfer (auto simp: plus_down_def)
 
 qualified lemma compute_float_le[code]: "a \<le> b \<longleftrightarrow> is_float_nonneg (float_plus_down 0 b (- a))"
   using truncate_down[of 0 "b - a"] truncate_down_nonneg[of "b - a" 0]
   by transfer (auto simp: plus_down_def)
 
 end
 
 lemma plus_down_mono: "plus_down p a b \<le> plus_down p c d" if "a + b \<le> c + d"
   by (auto simp: plus_down_def intro!: truncate_down_mono that)
 
 lemma plus_up_mono: "plus_up p a b \<le> plus_up p c d" if "a + b \<le> c + d"
   by (auto simp: plus_up_def intro!: truncate_up_mono that)
 
 subsection \<open>Approximate Multiplication\<close>
 
 lemma mult_mono_nonpos_nonneg: "a * b \<le> c * d"
   if  "a \<le> c" "a \<le> 0" "0 \<le> d" "d \<le> b" for a b c d::"'a::ordered_ring"
   by (meson dual_order.trans mult_left_mono_neg mult_right_mono that)
 
 lemma mult_mono_nonneg_nonpos: "b * a \<le> d * c"
   if  "a \<le> c" "c \<le> 0" "0 \<le> d" "d \<le> b" for a b c d::"'a::ordered_ring"
   by (meson dual_order.trans mult_right_mono_neg mult_left_mono that)
 
 lemma mult_mono_nonpos_nonpos: "a * b \<le> c * d"
   if  "a \<ge> c" "a \<le> 0" "b \<ge> d" "d \<le> 0" for a b c d::real
   by (meson dual_order.trans mult_left_mono_neg mult_right_mono_neg that)
 
 lemma mult_float_mono1:
   notes mono_rules = plus_down_mono add_mono nprt_mono nprt_le_zero zero_le_pprt pprt_mono
   shows "a \<le> b \<Longrightarrow> ab \<le> bb \<Longrightarrow>
        aa \<le> a \<Longrightarrow>
        b \<le> ba \<Longrightarrow>
        ac \<le> ab \<Longrightarrow>
        bb \<le> bc \<Longrightarrow>
        plus_down prec (nprt aa * pprt bc)
         (plus_down prec (nprt ba * nprt bc)
           (plus_down prec (pprt aa * pprt ac)
             (pprt ba * nprt ac)))
        \<le> plus_down prec (nprt a * pprt bb)
            (plus_down prec (nprt b * nprt bb)
              (plus_down prec (pprt a * pprt ab)
                (pprt b * nprt ab)))"
   apply (rule order_trans)
    apply (rule mono_rules | assumption)+
     apply (rule mult_mono_nonpos_nonneg)
        apply (rule mono_rules | assumption)+
     apply (rule mult_mono_nonpos_nonpos)
        apply (rule mono_rules | assumption)+
     apply (rule mult_mono)
        apply (rule mono_rules | assumption)+
    apply (rule mult_mono_nonneg_nonpos)
       apply (rule mono_rules | assumption)+
   by (rule order_refl)+
 
 lemma mult_float_mono2:
   notes mono_rules = plus_up_mono add_mono nprt_mono nprt_le_zero zero_le_pprt pprt_mono
   shows "a \<le> b \<Longrightarrow>
        ab \<le> bb \<Longrightarrow>
        aa \<le> a \<Longrightarrow>
        b \<le> ba \<Longrightarrow>
        ac \<le> ab \<Longrightarrow>
        bb \<le> bc \<Longrightarrow>
        plus_up prec (pprt b * pprt bb)
         (plus_up prec (pprt a * nprt bb)
           (plus_up prec (nprt b * pprt ab)
             (nprt a * nprt ab)))
        \<le> plus_up prec (pprt ba * pprt bc)
            (plus_up prec (pprt aa * nprt bc)
              (plus_up prec (nprt ba * pprt ac)
                (nprt aa * nprt ac)))"
   apply (rule order_trans)
    apply (rule mono_rules | assumption)+
     apply (rule mult_mono)
        apply (rule mono_rules | assumption)+
     apply (rule mult_mono_nonneg_nonpos)
        apply (rule mono_rules | assumption)+
     apply (rule mult_mono_nonpos_nonneg)
        apply (rule mono_rules | assumption)+
    apply (rule mult_mono_nonpos_nonpos)
       apply (rule mono_rules | assumption)+
   by (rule order_refl)+
 
 
 subsection \<open>Approximate Power\<close>
 
 lemma div2_less_self[termination_simp]: "odd n \<Longrightarrow> n div 2 < n" for n :: nat
   by (simp add: odd_pos)
 
 fun power_down :: "nat \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> real"
 where
   "power_down p x 0 = 1"
 | "power_down p x (Suc n) =
     (if odd n then truncate_down (Suc p) ((power_down p x (Suc n div 2))\<^sup>2)
      else truncate_down (Suc p) (x * power_down p x n))"
 
 fun power_up :: "nat \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> real"
 where
   "power_up p x 0 = 1"
 | "power_up p x (Suc n) =
     (if odd n then truncate_up p ((power_up p x (Suc n div 2))\<^sup>2)
      else truncate_up p (x * power_up p x n))"
 
 lift_definition power_up_fl :: "nat \<Rightarrow> float \<Rightarrow> nat \<Rightarrow> float" is power_up
   by (induct_tac rule: power_up.induct) simp_all
 
 lift_definition power_down_fl :: "nat \<Rightarrow> float \<Rightarrow> nat \<Rightarrow> float" is power_down
   by (induct_tac rule: power_down.induct) simp_all
 
 lemma power_float_transfer[transfer_rule]:
   "(rel_fun pcr_float (rel_fun (=) pcr_float)) (^) (^)"
   unfolding power_def
   by transfer_prover
 
 lemma compute_power_up_fl[code]:
     "power_up_fl p x 0 = 1"
     "power_up_fl p x (Suc n) =
       (if odd n then float_round_up p ((power_up_fl p x (Suc n div 2))\<^sup>2)
        else float_round_up p (x * power_up_fl p x n))"
   and compute_power_down_fl[code]:
     "power_down_fl p x 0 = 1"
     "power_down_fl p x (Suc n) =
       (if odd n then float_round_down (Suc p) ((power_down_fl p x (Suc n div 2))\<^sup>2)
        else float_round_down (Suc p) (x * power_down_fl p x n))"
   unfolding atomize_conj by transfer simp
 
 lemma power_down_pos: "0 < x \<Longrightarrow> 0 < power_down p x n"
   by (induct p x n rule: power_down.induct)
     (auto simp del: odd_Suc_div_two intro!: truncate_down_pos)
 
 lemma power_down_nonneg: "0 \<le> x \<Longrightarrow> 0 \<le> power_down p x n"
   by (induct p x n rule: power_down.induct)
     (auto simp del: odd_Suc_div_two intro!: truncate_down_nonneg mult_nonneg_nonneg)
 
 lemma power_down: "0 \<le> x \<Longrightarrow> power_down p x n \<le> x ^ n"
 proof (induct p x n rule: power_down.induct)
   case (2 p x n)
   have ?case if "odd n"
   proof -
     from that 2 have "(power_down p x (Suc n div 2)) ^ 2 \<le> (x ^ (Suc n div 2)) ^ 2"
       by (auto intro: power_mono power_down_nonneg simp del: odd_Suc_div_two)
     also have "\<dots> = x ^ (Suc n div 2 * 2)"
       by (simp flip: power_mult)
     also have "Suc n div 2 * 2 = Suc n"
       using \<open>odd n\<close> by presburger
     finally show ?thesis
       using that by (auto intro!: truncate_down_le simp del: odd_Suc_div_two)
   qed
   then show ?case
     by (auto intro!: truncate_down_le mult_left_mono 2 mult_nonneg_nonneg power_down_nonneg)
 qed simp
 
 lemma power_up: "0 \<le> x \<Longrightarrow> x ^ n \<le> power_up p x n"
 proof (induct p x n rule: power_up.induct)
   case (2 p x n)
   have ?case if "odd n"
   proof -
     from that even_Suc have "Suc n = Suc n div 2 * 2"
       by presburger
     then have "x ^ Suc n \<le> (x ^ (Suc n div 2))\<^sup>2"
       by (simp flip: power_mult)
     also from that 2 have "\<dots> \<le> (power_up p x (Suc n div 2))\<^sup>2"
       by (auto intro: power_mono simp del: odd_Suc_div_two)
     finally show ?thesis
       using that by (auto intro!: truncate_up_le simp del: odd_Suc_div_two)
   qed
   then show ?case
     by (auto intro!: truncate_up_le mult_left_mono 2)
 qed simp
 
 lemmas power_up_le = order_trans[OF _ power_up]
   and power_up_less = less_le_trans[OF _ power_up]
   and power_down_le = order_trans[OF power_down]
 
 lemma power_down_fl: "0 \<le> x \<Longrightarrow> power_down_fl p x n \<le> x ^ n"
   by transfer (rule power_down)
 
 lemma power_up_fl: "0 \<le> x \<Longrightarrow> x ^ n \<le> power_up_fl p x n"
   by transfer (rule power_up)
 
 lemma real_power_up_fl: "real_of_float (power_up_fl p x n) = power_up p x n"
   by transfer simp
 
 lemma real_power_down_fl: "real_of_float (power_down_fl p x n) = power_down p x n"
   by transfer simp
 
 lemmas [simp del] = power_down.simps(2) power_up.simps(2)
 
 lemmas power_down_simp = power_down.simps(2)
 lemmas power_up_simp = power_up.simps(2)
 
 lemma power_down_even_nonneg: "even n \<Longrightarrow> 0 \<le> power_down p x n"
   by (induct p x n rule: power_down.induct)
     (auto simp: power_down_simp simp del: odd_Suc_div_two intro!: truncate_down_nonneg )
 
 lemma power_down_eq_zero_iff[simp]: "power_down prec b n = 0 \<longleftrightarrow> b = 0 \<and> n \<noteq> 0"
 proof (induction n arbitrary: b rule: less_induct)
   case (less x)
   then show ?case
     using power_down_simp[of _ _ "x - 1"]
     by (cases x) (auto simp add: div2_less_self)
 qed
 
 lemma power_down_nonneg_iff[simp]:
   "power_down prec b n \<ge> 0 \<longleftrightarrow> even n \<or> b \<ge> 0"
 proof (induction n arbitrary: b rule: less_induct)
   case (less x)
   show ?case
     using less(1)[of "x - 1" b] power_down_simp[of _ _ "x - 1"]
     by (cases x) (auto simp: algebra_split_simps zero_le_mult_iff)
 qed
 
 lemma power_down_neg_iff[simp]:
   "power_down prec b n < 0 \<longleftrightarrow>
     b < 0 \<and> odd n"
   using power_down_nonneg_iff[of prec b n] by (auto simp del: power_down_nonneg_iff)
 
 lemma power_down_nonpos_iff[simp]:
   notes [simp del] = power_down_neg_iff power_down_eq_zero_iff
   shows "power_down prec b n \<le> 0 \<longleftrightarrow> b < 0 \<and> odd n \<or> b = 0 \<and> n \<noteq> 0"
   using power_down_neg_iff[of prec b n] power_down_eq_zero_iff[of prec b n]
   by auto
 
 lemma power_down_mono:
   "power_down prec a n \<le> power_down prec b n"
   if "((0 \<le> a \<and> a \<le> b)\<or>(odd n \<and> a \<le> b) \<or> (even n \<and> a \<le> 0 \<and> b \<le> a))"
   using that
 proof (induction n arbitrary: a b rule: less_induct)
   case (less i)
   show ?case
   proof (cases i)
     case j: (Suc j)
     note IH = less[unfolded j even_Suc not_not]
     note [simp del] = power_down.simps
     show ?thesis
     proof cases
       assume [simp]: "even j"
       have "a * power_down prec a j \<le> b * power_down prec b j"
-        by (smt IH(1) IH(2) \<open>even j\<close> lessI mult_mono' mult_mono_nonpos_nonneg power_down_even_nonneg)
+        by (metis IH(1) IH(2) \<open>even j\<close> lessI linear mult_mono mult_mono' mult_mono_nonpos_nonneg power_down_even_nonneg)
       then have "truncate_down (Suc prec) (a * power_down prec a j) \<le> truncate_down (Suc prec) (b * power_down prec b j)"
         by (auto intro!: truncate_down_mono simp: abs_le_square_iff[symmetric] abs_real_def)
       then show ?thesis
         unfolding j
         by (simp add: power_down_simp)
     next
       assume [simp]: "odd j"
       have "power_down prec 0 (Suc (j div 2)) \<le> - power_down prec b (Suc (j div 2))"
         if "b < 0" "even (j div 2)"
         apply (rule order_trans[where y=0])
         using IH that by (auto simp: div2_less_self)
       then have "truncate_down (Suc prec) ((power_down prec a (Suc (j div 2)))\<^sup>2)
         \<le> truncate_down (Suc prec) ((power_down prec b (Suc (j div 2)))\<^sup>2)"
         using IH
         by (auto intro!: truncate_down_mono intro: order_trans[where y=0]
             simp: abs_le_square_iff[symmetric] abs_real_def
             div2_less_self)
       then show ?thesis
         unfolding j
         by (simp add: power_down_simp)
     qed
   qed simp
 qed
 
 lemma power_up_even_nonneg: "even n \<Longrightarrow> 0 \<le> power_up p x n"
   by (induct p x n rule: power_up.induct)
     (auto simp: power_up.simps simp del: odd_Suc_div_two intro!: )
 
 lemma power_up_eq_zero_iff[simp]: "power_up prec b n = 0 \<longleftrightarrow> b = 0 \<and> n \<noteq> 0"
 proof (induction n arbitrary: b rule: less_induct)
   case (less x)
   then show ?case
     using power_up_simp[of _ _ "x - 1"]
     by (cases x) (auto simp: algebra_split_simps zero_le_mult_iff div2_less_self)
 qed
 
 lemma power_up_nonneg_iff[simp]:
   "power_up prec b n \<ge> 0 \<longleftrightarrow> even n \<or> b \<ge> 0"
 proof (induction n arbitrary: b rule: less_induct)
   case (less x)
   show ?case
     using less(1)[of "x - 1" b] power_up_simp[of _ _ "x - 1"]
     by (cases x) (auto simp: algebra_split_simps zero_le_mult_iff)
 qed
 
 lemma power_up_neg_iff[simp]:
   "power_up prec b n < 0 \<longleftrightarrow> b < 0 \<and> odd n"
   using power_up_nonneg_iff[of prec b n] by (auto simp del: power_up_nonneg_iff)
 
 lemma power_up_nonpos_iff[simp]:
   notes [simp del] = power_up_neg_iff power_up_eq_zero_iff
   shows "power_up prec b n \<le> 0 \<longleftrightarrow> b < 0 \<and> odd n \<or> b = 0 \<and> n \<noteq> 0"
   using power_up_neg_iff[of prec b n] power_up_eq_zero_iff[of prec b n]
   by auto
 
 lemma power_up_mono:
   "power_up prec a n \<le> power_up prec b n"
   if "((0 \<le> a \<and> a \<le> b)\<or>(odd n \<and> a \<le> b) \<or> (even n \<and> a \<le> 0 \<and> b \<le> a))"
   using that
 proof (induction n arbitrary: a b rule: less_induct)
   case (less i)
   show ?case
   proof (cases i)
     case j: (Suc j)
     note IH = less[unfolded j even_Suc not_not]
     note [simp del] = power_up.simps
     show ?thesis
     proof cases
       assume [simp]: "even j"
       have "a * power_up prec a j \<le> b * power_up prec b j"
-        by (smt IH(1) IH(2) \<open>even j\<close> lessI mult_mono' mult_mono_nonpos_nonneg power_up_even_nonneg)
+        by (metis IH(1) IH(2) \<open>even j\<close> lessI linear mult_mono mult_mono' mult_mono_nonpos_nonneg power_up_even_nonneg)
       then have "truncate_up prec (a * power_up prec a j) \<le> truncate_up prec (b * power_up prec b j)"
         by (auto intro!: truncate_up_mono simp: abs_le_square_iff[symmetric] abs_real_def)
       then show ?thesis
         unfolding j
         by (simp add: power_up_simp)
     next
       assume [simp]: "odd j"
       have "power_up prec 0 (Suc (j div 2)) \<le> - power_up prec b (Suc (j div 2))"
         if "b < 0" "even (j div 2)"
         apply (rule order_trans[where y=0])
         using IH that by (auto simp: div2_less_self)
       then have "truncate_up prec ((power_up prec a (Suc (j div 2)))\<^sup>2)
         \<le> truncate_up prec ((power_up prec b (Suc (j div 2)))\<^sup>2)"
         using IH
         by (auto intro!: truncate_up_mono intro: order_trans[where y=0]
             simp: abs_le_square_iff[symmetric] abs_real_def
             div2_less_self)
       then show ?thesis
         unfolding j
         by (simp add: power_up_simp)
     qed
   qed simp
 qed
 
 
 subsection \<open>Lemmas needed by Approximate\<close>
 
 lemma Float_num[simp]:
    "real_of_float (Float 1 0) = 1"
    "real_of_float (Float 1 1) = 2"
    "real_of_float (Float 1 2) = 4"
    "real_of_float (Float 1 (- 1)) = 1/2"
    "real_of_float (Float 1 (- 2)) = 1/4"
    "real_of_float (Float 1 (- 3)) = 1/8"
    "real_of_float (Float (- 1) 0) = -1"
    "real_of_float (Float (numeral n) 0) = numeral n"
    "real_of_float (Float (- numeral n) 0) = - numeral n"
   using two_powr_int_float[of 2] two_powr_int_float[of "-1"] two_powr_int_float[of "-2"]
     two_powr_int_float[of "-3"]
   using powr_realpow[of 2 2] powr_realpow[of 2 3]
   using powr_minus[of "2::real" 1] powr_minus[of "2::real" 2] powr_minus[of "2::real" 3]
   by auto
 
 lemma real_of_Float_int[simp]: "real_of_float (Float n 0) = real n"
   by simp
 
 lemma float_zero[simp]: "real_of_float (Float 0 e) = 0"
   by simp
 
 lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> \<bar>(a::int) div 2\<bar> < \<bar>a\<bar>"
   by arith
 
 lemma lapprox_rat: "real_of_float (lapprox_rat prec x y) \<le> real_of_int x / real_of_int y"
   by (simp add: lapprox_rat.rep_eq truncate_down)
 
 lemma mult_div_le:
   fixes a b :: int
   assumes "b > 0"
   shows "a \<ge> b * (a div b)"
 proof -
   from minus_div_mult_eq_mod [symmetric, of a b] have "a = b * (a div b) + a mod b"
     by simp
   also have "\<dots> \<ge> b * (a div b) + 0"
     apply (rule add_left_mono)
     apply (rule pos_mod_sign)
     using assms
     apply simp
     done
   finally show ?thesis
     by simp
 qed
 
 lemma lapprox_rat_nonneg:
   assumes "0 \<le> x" and "0 \<le> y"
   shows "0 \<le> real_of_float (lapprox_rat n x y)"
   using assms
   by transfer (simp add: truncate_down_nonneg)
 
 lemma rapprox_rat: "real_of_int x / real_of_int y \<le> real_of_float (rapprox_rat prec x y)"
   by transfer (simp add: truncate_up)
 
 lemma rapprox_rat_le1:
   assumes "0 \<le> x" "0 < y" "x \<le> y"
   shows "real_of_float (rapprox_rat n x y) \<le> 1"
   using assms
   by transfer (simp add: truncate_up_le1)
 
 lemma rapprox_rat_nonneg_nonpos: "0 \<le> x \<Longrightarrow> y \<le> 0 \<Longrightarrow> real_of_float (rapprox_rat n x y) \<le> 0"
   by transfer (simp add: truncate_up_nonpos divide_nonneg_nonpos)
 
 lemma rapprox_rat_nonpos_nonneg: "x \<le> 0 \<Longrightarrow> 0 \<le> y \<Longrightarrow> real_of_float (rapprox_rat n x y) \<le> 0"
   by transfer (simp add: truncate_up_nonpos divide_nonpos_nonneg)
 
 lemma real_divl: "real_divl prec x y \<le> x / y"
   by (simp add: real_divl_def truncate_down)
 
 lemma real_divr: "x / y \<le> real_divr prec x y"
   by (simp add: real_divr_def truncate_up)
 
 lemma float_divl: "real_of_float (float_divl prec x y) \<le> x / y"
   by transfer (rule real_divl)
 
 lemma real_divl_lower_bound: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> real_divl prec x y"
   by (simp add: real_divl_def truncate_down_nonneg)
 
 lemma float_divl_lower_bound: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> real_of_float (float_divl prec x y)"
   by transfer (rule real_divl_lower_bound)
 
 lemma exponent_1: "exponent 1 = 0"
   using exponent_float[of 1 0] by (simp add: one_float_def)
 
 lemma mantissa_1: "mantissa 1 = 1"
   using mantissa_float[of 1 0] by (simp add: one_float_def)
 
 lemma bitlen_1: "bitlen 1 = 1"
   by (simp add: bitlen_alt_def)
 
 lemma float_upper_bound: "x \<le> 2 powr (bitlen \<bar>mantissa x\<bar> + exponent x)"
 proof (cases "x = 0")
   case True
   then show ?thesis by simp
 next
   case False
   then have "mantissa x \<noteq> 0"
     using mantissa_eq_zero_iff by auto
   have "x = mantissa x * 2 powr (exponent x)"
     by (rule mantissa_exponent)
   also have "mantissa x \<le> \<bar>mantissa x\<bar>"
     by simp
   also have "\<dots> \<le> 2 powr (bitlen \<bar>mantissa x\<bar>)"
     using bitlen_bounds[of "\<bar>mantissa x\<bar>"] bitlen_nonneg \<open>mantissa x \<noteq> 0\<close>
     by (auto simp del: of_int_abs simp add: powr_int)
   finally show ?thesis by (simp add: powr_add)
 qed
 
 lemma real_divl_pos_less1_bound:
   assumes "0 < x" "x \<le> 1"
   shows "1 \<le> real_divl prec 1 x"
   using assms
   by (auto intro!: truncate_down_ge1 simp: real_divl_def)
 
 lemma float_divl_pos_less1_bound:
   "0 < real_of_float x \<Longrightarrow> real_of_float x \<le> 1 \<Longrightarrow> prec \<ge> 1 \<Longrightarrow>
     1 \<le> real_of_float (float_divl prec 1 x)"
   by transfer (rule real_divl_pos_less1_bound)
 
 lemma float_divr: "real_of_float x / real_of_float y \<le> real_of_float (float_divr prec x y)"
   by transfer (rule real_divr)
 
 lemma real_divr_pos_less1_lower_bound:
   assumes "0 < x"
     and "x \<le> 1"
   shows "1 \<le> real_divr prec 1 x"
 proof -
   have "1 \<le> 1 / x"
     using \<open>0 < x\<close> and \<open>x \<le> 1\<close> by auto
   also have "\<dots> \<le> real_divr prec 1 x"
     using real_divr[where x = 1 and y = x] by auto
   finally show ?thesis by auto
 qed
 
 lemma float_divr_pos_less1_lower_bound: "0 < x \<Longrightarrow> x \<le> 1 \<Longrightarrow> 1 \<le> float_divr prec 1 x"
   by transfer (rule real_divr_pos_less1_lower_bound)
 
 lemma real_divr_nonpos_pos_upper_bound: "x \<le> 0 \<Longrightarrow> 0 \<le> y \<Longrightarrow> real_divr prec x y \<le> 0"
   by (simp add: real_divr_def truncate_up_nonpos divide_le_0_iff)
 
 lemma float_divr_nonpos_pos_upper_bound:
   "real_of_float x \<le> 0 \<Longrightarrow> 0 \<le> real_of_float y \<Longrightarrow> real_of_float (float_divr prec x y) \<le> 0"
   by transfer (rule real_divr_nonpos_pos_upper_bound)
 
 lemma real_divr_nonneg_neg_upper_bound: "0 \<le> x \<Longrightarrow> y \<le> 0 \<Longrightarrow> real_divr prec x y \<le> 0"
   by (simp add: real_divr_def truncate_up_nonpos divide_le_0_iff)
 
 lemma float_divr_nonneg_neg_upper_bound:
   "0 \<le> real_of_float x \<Longrightarrow> real_of_float y \<le> 0 \<Longrightarrow> real_of_float (float_divr prec x y) \<le> 0"
   by transfer (rule real_divr_nonneg_neg_upper_bound)
 
 lemma Float_le_zero_iff: "Float a b \<le> 0 \<longleftrightarrow> a \<le> 0"
   by (auto simp: zero_float_def mult_le_0_iff)
 
 lemma real_of_float_pprt[simp]:
   fixes a :: float
   shows "real_of_float (pprt a) = pprt (real_of_float a)"
   unfolding pprt_def sup_float_def max_def sup_real_def by auto
 
 lemma real_of_float_nprt[simp]:
   fixes a :: float
   shows "real_of_float (nprt a) = nprt (real_of_float a)"
   unfolding nprt_def inf_float_def min_def inf_real_def by auto
 
 context
 begin
 
 lift_definition int_floor_fl :: "float \<Rightarrow> int" is floor .
 
 qualified lemma compute_int_floor_fl[code]:
   "int_floor_fl (Float m e) = (if 0 \<le> e then m * 2 ^ nat e else m div (2 ^ (nat (-e))))"
   apply transfer
   apply (simp add: powr_int floor_divide_of_int_eq)
   apply (metis (no_types, hide_lams)floor_divide_of_int_eq of_int_numeral of_int_power floor_of_int of_int_mult)
   done
 
 lift_definition floor_fl :: "float \<Rightarrow> float" is "\<lambda>x. real_of_int \<lfloor>x\<rfloor>"
   by simp
 
 qualified lemma compute_floor_fl[code]:
   "floor_fl (Float m e) = (if 0 \<le> e then Float m e else Float (m div (2 ^ (nat (-e)))) 0)"
   apply transfer
   apply (simp add: powr_int floor_divide_of_int_eq)
   apply (metis (no_types, hide_lams)floor_divide_of_int_eq of_int_numeral of_int_power of_int_mult)
   done
 
 end
 
 lemma floor_fl: "real_of_float (floor_fl x) \<le> real_of_float x"
   by transfer simp
 
 lemma int_floor_fl: "real_of_int (int_floor_fl x) \<le> real_of_float x"
   by transfer simp
 
 lemma floor_pos_exp: "exponent (floor_fl x) \<ge> 0"
 proof (cases "floor_fl x = 0")
   case True
   then show ?thesis
     by (simp add: floor_fl_def)
 next
   case False
   have eq: "floor_fl x = Float \<lfloor>real_of_float x\<rfloor> 0"
     by transfer simp
   obtain i where "\<lfloor>real_of_float x\<rfloor> = mantissa (floor_fl x) * 2 ^ i" "0 = exponent (floor_fl x) - int i"
     by (rule denormalize_shift[OF eq False])
   then show ?thesis
     by simp
 qed
 
 lemma compute_mantissa[code]:
   "mantissa (Float m e) =
     (if m = 0 then 0 else if 2 dvd m then mantissa (normfloat (Float m e)) else m)"
   by (auto simp: mantissa_float Float.abs_eq simp flip: zero_float_def)
 
 lemma compute_exponent[code]:
   "exponent (Float m e) =
     (if m = 0 then 0 else if 2 dvd m then exponent (normfloat (Float m e)) else e)"
   by (auto simp: exponent_float Float.abs_eq simp flip: zero_float_def)
 
 lifting_update Float.float.lifting
 lifting_forget Float.float.lifting
 
 end
diff --git a/src/HOL/Library/Interval_Float.thy b/src/HOL/Library/Interval_Float.thy
--- a/src/HOL/Library/Interval_Float.thy
+++ b/src/HOL/Library/Interval_Float.thy
@@ -1,361 +1,361 @@
 section \<open>Approximate Operations on Intervals of Floating Point Numbers\<close>
 theory Interval_Float
   imports
     Interval
     Float
 begin
 
 definition mid :: "float interval \<Rightarrow> float"
   where "mid i = (lower i + upper i) * Float 1 (-1)"
 
 lemma mid_in_interval: "mid i \<in>\<^sub>i i"
   using lower_le_upper[of i]
   by (auto simp: mid_def set_of_eq powr_minus)
 
 lemma mid_le: "lower i \<le> mid i" "mid i \<le> upper i"
   using mid_in_interval
   by (auto simp: set_of_eq)
 
 definition centered :: "float interval \<Rightarrow> float interval"
   where "centered i = i - interval_of (mid i)"
 
 definition "split_float_interval x = split_interval x ((lower x + upper x) * Float 1 (-1))"
 
 lemma split_float_intervalD: "split_float_interval X = (A, B) \<Longrightarrow> set_of X \<subseteq> set_of A \<union> set_of B"
   by (auto dest!: split_intervalD simp: split_float_interval_def)
 
 lemma split_float_interval_bounds:
   shows
     lower_split_float_interval1: "lower (fst (split_float_interval X)) = lower X"
   and lower_split_float_interval2: "lower (snd (split_float_interval X)) = mid X"
   and upper_split_float_interval1: "upper (fst (split_float_interval X)) = mid X"
   and upper_split_float_interval2: "upper (snd (split_float_interval X)) = upper X"
   using mid_le[of X]
   by (auto simp: split_float_interval_def mid_def[symmetric] min_def max_def real_of_float_eq
       lower_split_interval1 lower_split_interval2
       upper_split_interval1 upper_split_interval2)
 
 lemmas float_round_down_le[intro] = order_trans[OF float_round_down]
   and float_round_up_ge[intro] = order_trans[OF _ float_round_up]
 
 text \<open>TODO: many of the lemmas should move to theories Float or Approximation
   (the latter should be based on type @{type interval}.\<close>
 
 subsection "Intervals with Floating Point Bounds"
 
 context includes interval.lifting begin
 
 lift_definition round_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval"
   is "\<lambda>p. \<lambda>(l, u). (float_round_down p l, float_round_up p u)"
   by (auto simp: intro!: float_round_down_le float_round_up_le)
 
 lemma lower_round_ivl[simp]: "lower (round_interval p x) = float_round_down p (lower x)"
   by transfer auto
 lemma upper_round_ivl[simp]: "upper (round_interval p x) = float_round_up p (upper x)"
   by transfer auto
 
 lemma round_ivl_correct: "set_of A \<subseteq> set_of (round_interval prec A)"
   by (auto simp: set_of_eq float_round_down_le float_round_up_le)
 
 lift_definition truncate_ivl :: "nat \<Rightarrow> real interval \<Rightarrow> real interval"
   is "\<lambda>p. \<lambda>(l, u). (truncate_down p l, truncate_up p u)"
   by (auto intro!: truncate_down_le truncate_up_le)
 
 lemma lower_truncate_ivl[simp]: "lower (truncate_ivl p x) = truncate_down p (lower x)"
   by transfer auto
 lemma upper_truncate_ivl[simp]: "upper (truncate_ivl p x) = truncate_up p (upper x)"
   by transfer auto
 
 lemma truncate_ivl_correct: "set_of A \<subseteq> set_of (truncate_ivl prec A)"
   by (auto simp: set_of_eq intro!: truncate_down_le truncate_up_le)
 
 lift_definition real_interval::"float interval \<Rightarrow> real interval"
   is "\<lambda>(l, u). (real_of_float l, real_of_float u)"
   by auto
 
 lemma lower_real_interval[simp]: "lower (real_interval x) = lower x"
   by transfer auto
 lemma upper_real_interval[simp]: "upper (real_interval x) = upper x"
   by transfer auto
 
 definition "set_of' x = (case x of None \<Rightarrow> UNIV | Some i \<Rightarrow> set_of (real_interval i))"
 
 lemma real_interval_min_interval[simp]:
   "real_interval (min_interval a b) = min_interval (real_interval a) (real_interval b)"
   by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_min)
 
 lemma real_interval_max_interval[simp]:
   "real_interval (max_interval a b) = max_interval (real_interval a) (real_interval b)"
   by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_max)
 
 lemma in_intervalI:
   "x \<in>\<^sub>i X" if "lower X \<le> x" "x \<le> upper X"
   using that by (auto simp: set_of_eq)
 
 abbreviation in_real_interval ("(_/ \<in>\<^sub>r _)" [51, 51] 50) where
   "x \<in>\<^sub>r X \<equiv> x \<in>\<^sub>i real_interval X"
 
 lemma in_real_intervalI:
   "x \<in>\<^sub>r X" if "lower X \<le> x" "x \<le> upper X" for x::real and X::"float interval"
   using that
   by (intro in_intervalI) auto
 
 subsection \<open>intros for \<open>real_interval\<close>\<close>
 
 lemma in_round_intervalI: "x \<in>\<^sub>r A  \<Longrightarrow> x \<in>\<^sub>r (round_interval prec A)"
   by (auto simp: set_of_eq float_round_down_le float_round_up_le)
 
 lemma zero_in_float_intervalI: "0 \<in>\<^sub>r 0"
   by (auto simp: set_of_eq)
 
 lemma plus_in_float_intervalI: "a + b \<in>\<^sub>r A + B" if "a \<in>\<^sub>r A" "b \<in>\<^sub>r B"
   using that
   by (auto simp: set_of_eq)
 
 lemma minus_in_float_intervalI: "a - b \<in>\<^sub>r A - B" if "a \<in>\<^sub>r A" "b \<in>\<^sub>r B"
   using that
   by (auto simp: set_of_eq)
 
 lemma uminus_in_float_intervalI: "-a \<in>\<^sub>r -A" if "a \<in>\<^sub>r A"
   using that
   by (auto simp: set_of_eq)
 
 lemma real_interval_times: "real_interval (A * B) = real_interval A * real_interval B"
   by (auto simp: interval_eq_iff lower_times upper_times min_def max_def)
 
 lemma times_in_float_intervalI: "a * b \<in>\<^sub>r A * B" if "a \<in>\<^sub>r A" "b \<in>\<^sub>r B"
   using times_in_intervalI[OF that]
   by (auto simp: real_interval_times)
 
 lemma real_interval_abs: "real_interval (abs_interval A) = abs_interval (real_interval A)"
   by (auto simp: interval_eq_iff min_def max_def)
 
 lemma abs_in_float_intervalI: "abs a \<in>\<^sub>r abs_interval A" if "a \<in>\<^sub>r A"
   by (auto simp: set_of_abs_interval real_interval_abs intro!: imageI that)
 
 lemma interval_of[intro,simp]: "x \<in>\<^sub>r interval_of x"
   by (auto simp: set_of_eq)
 
 lemma split_float_interval_realD: "split_float_interval X = (A, B) \<Longrightarrow> x \<in>\<^sub>r X \<Longrightarrow> x \<in>\<^sub>r A \<or> x \<in>\<^sub>r B"
   by (auto simp: set_of_eq prod_eq_iff split_float_interval_bounds)
 
 
 subsection \<open>bounds for lists\<close>
 
 lemma lower_Interval: "lower (Interval x) = fst x"
   and upper_Interval: "upper (Interval x) = snd x"
   if "fst x \<le> snd x"
   using that
   by (auto simp: lower_def upper_def Interval_inverse split_beta')
 
 definition all_in_i :: "'a::preorder list \<Rightarrow> 'a interval list \<Rightarrow> bool"
   (infix "(all'_in\<^sub>i)" 50)
   where "x all_in\<^sub>i I = (length x = length I \<and> (\<forall>i < length I. x ! i \<in>\<^sub>i I ! i))"
 
 definition all_in :: "real list \<Rightarrow> float interval list \<Rightarrow> bool"
   (infix "(all'_in)" 50)
   where "x all_in I = (length x = length I \<and> (\<forall>i < length I. x ! i \<in>\<^sub>r I ! i))"
 
 definition all_subset :: "'a::order interval list \<Rightarrow> 'a interval list \<Rightarrow> bool"
   (infix "(all'_subset)" 50)
   where "I all_subset J = (length I = length J \<and> (\<forall>i < length I. set_of (I!i) \<subseteq> set_of (J!i)))"
 
 lemmas [simp] = all_in_def all_subset_def
 
 lemma all_subsetD:
   assumes "I all_subset J"
   assumes "x all_in I"
   shows "x all_in J"
   using assms
   by (auto simp: set_of_eq; fastforce)
 
 lemma round_interval_mono: "set_of (round_interval prec X) \<subseteq> set_of (round_interval prec Y)"
   if "set_of X \<subseteq> set_of Y"
   using that
   by transfer
     (auto simp: float_round_down.rep_eq float_round_up.rep_eq truncate_down_mono truncate_up_mono)
 
 lemma Ivl_simps[simp]: "lower (Ivl a b) = min a b" "upper (Ivl a b) = b"
   subgoal by transfer simp
   subgoal by transfer simp
   done
 
 lemma set_of_subset_iff: "set_of X \<subseteq> set_of Y \<longleftrightarrow> lower Y \<le> lower X \<and> upper X \<le> upper Y"
   for X Y::"'a::linorder interval"
   by (auto simp: set_of_eq subset_iff)
 
 lemma set_of_subset_iff':
   "set_of a \<subseteq> set_of (b :: 'a :: linorder interval) \<longleftrightarrow> a \<le> b"
   unfolding less_eq_interval_def set_of_subset_iff ..
 
 lemma bounds_of_interval_eq_lower_upper:
   "bounds_of_interval ivl = (lower ivl, upper ivl)" if "lower ivl \<le> upper ivl"
   using that
   by (auto simp: lower.rep_eq upper.rep_eq)
 
 lemma real_interval_Ivl: "real_interval (Ivl a b) = Ivl a b"
   by transfer (auto simp: min_def)
 
 lemma set_of_mul_contains_real_zero:
   "0 \<in>\<^sub>r (A * B)" if "0 \<in>\<^sub>r A \<or> 0 \<in>\<^sub>r B"
   using that set_of_mul_contains_zero[of A B]
   by (auto simp: set_of_eq)
 
 fun subdivide_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval list"
   where "subdivide_interval 0 I = [I]"
   | "subdivide_interval (Suc n) I = (
          let m = mid I
          in (subdivide_interval n (Ivl (lower I) m)) @ (subdivide_interval n (Ivl m (upper I)))
        )"
 
 lemma subdivide_interval_length:
   shows "length (subdivide_interval n I) = 2^n"
   by(induction n arbitrary: I, simp_all add: Let_def)
 
 lemma lower_le_mid: "lower x \<le> mid x" "real_of_float (lower x) \<le> mid x"
   and mid_le_upper: "mid x \<le> upper x" "real_of_float (mid x) \<le> upper x"
   unfolding mid_def
   subgoal by transfer (auto simp: powr_neg_one)
   subgoal by transfer (auto simp: powr_neg_one)
   subgoal by transfer (auto simp: powr_neg_one)
   subgoal by transfer (auto simp: powr_neg_one)
   done
 
 lemma subdivide_interval_correct:
   "list_ex (\<lambda>i. x \<in>\<^sub>r i) (subdivide_interval n I)" if "x \<in>\<^sub>r I" for x::real
   using that
 proof(induction n arbitrary: x I)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   from \<open>x \<in>\<^sub>r I\<close> consider "x \<in>\<^sub>r Ivl (lower I) (mid I)" | "x \<in>\<^sub>r Ivl (mid I) (upper I)"
     by (cases "x \<le> real_of_float (mid I)")
       (auto simp: set_of_eq min_def lower_le_mid mid_le_upper)
   from this[case_names lower upper] show ?case
     by cases (use Suc.IH in \<open>auto simp: Let_def\<close>)
 qed
 
 fun interval_list_union :: "'a::lattice interval list \<Rightarrow> 'a interval"
   where "interval_list_union [] = undefined"
   | "interval_list_union [I] = I"
   | "interval_list_union (I#Is) = sup I (interval_list_union Is)"
 
 lemma interval_list_union_correct:
   assumes "S \<noteq> []"
   assumes "i < length S"
   shows "set_of (S!i) \<subseteq> set_of (interval_list_union S)"
   using assms
 proof(induction S arbitrary: i)
   case (Cons a S i)
   thus ?case
   proof(cases S)
     fix b S'
     assume "S = b # S'"
     hence "S \<noteq> []"
       by simp
     show ?thesis
     proof(cases i)
       case 0
       show ?thesis
         apply(cases S)
         using interval_union_mono1
         by (auto simp add: 0)
     next
       case (Suc i_prev)
       hence "i_prev < length S"
         using Cons(3) by simp
 
       from Cons(1)[OF \<open>S \<noteq> []\<close> this] Cons(1)
       have "set_of ((a # S) ! i) \<subseteq> set_of (interval_list_union S)"
         by (simp add: \<open>i = Suc i_prev\<close>)
       also have "... \<subseteq> set_of (interval_list_union (a # S))"
         using \<open>S \<noteq> []\<close>
         apply(cases S)
         using interval_union_mono2
         by auto
       finally show ?thesis .
     qed
   qed simp
 qed simp
 
 lemma split_domain_correct:
   fixes x :: "real list"
   assumes "x all_in I"
   assumes split_correct: "\<And>x a I. x \<in>\<^sub>r I \<Longrightarrow> list_ex (\<lambda>i::float interval. x \<in>\<^sub>r i) (split I)"
   shows "list_ex (\<lambda>s. x all_in s) (split_domain split I)"
   using assms(1)
 proof(induction I arbitrary: x)
   case (Cons I Is x)
   have "x \<noteq> []"
     using Cons(2) by auto
   obtain x' xs where x_decomp: "x = x' # xs"
     using \<open>x \<noteq> []\<close> list.exhaust by auto
   hence "x' \<in>\<^sub>r I" "xs all_in Is"
     using Cons(2)
     by auto
   show ?case
     using Cons(1)[OF \<open>xs all_in Is\<close>]
       split_correct[OF \<open>x' \<in>\<^sub>r I\<close>]
     apply (auto simp add: list_ex_iff set_of_eq)
-    by (smt length_Cons less_Suc_eq_0_disj nth_Cons_0 nth_Cons_Suc x_decomp)
+    by (smt (verit, ccfv_SIG) One_nat_def Suc_pred \<open>x \<noteq> []\<close> le_simps(3) length_greater_0_conv length_tl linorder_not_less list.sel(3) neq0_conv nth_Cons' x_decomp)
 qed simp
 
 
 lift_definition(code_dt) inverse_float_interval::"nat \<Rightarrow> float interval \<Rightarrow> float interval option" is
   "\<lambda>prec (l, u). if (0 < l \<or> u < 0) then Some (float_divl prec 1 u, float_divr prec 1 l) else None"
   by (auto intro!: order_trans[OF float_divl] order_trans[OF _ float_divr]
       simp: divide_simps)
 
 lemma inverse_float_interval_eq_Some_conv:
   defines "one \<equiv> (1::float)"
   shows 
     "inverse_float_interval p X = Some R \<longleftrightarrow>
     (lower X > 0 \<or> upper X < 0) \<and>
     lower R = float_divl p one (upper X) \<and>
     upper R = float_divr p one (lower X)"
   by clarsimp (transfer fixing: one, force simp: one_def split: if_splits)
 
 lemma inverse_float_interval:
   "inverse ` set_of (real_interval X) \<subseteq> set_of (real_interval Y)"
   if "inverse_float_interval p X = Some Y"
   using that
   apply (clarsimp simp: set_of_eq inverse_float_interval_eq_Some_conv)
   by (intro order_trans[OF float_divl] order_trans[OF _ float_divr] conjI)
     (auto simp: divide_simps)
 
 lemma inverse_float_intervalI:
   "x \<in>\<^sub>r X \<Longrightarrow> inverse x \<in> set_of' (inverse_float_interval p X)"
   using inverse_float_interval[of p X]
   by (auto simp: set_of'_def split: option.splits)
 
 lemma inverse_float_interval_eqI: "inverse_float_interval p X = Some IVL \<Longrightarrow> x \<in>\<^sub>r X \<Longrightarrow> inverse x \<in>\<^sub>r IVL"
   using inverse_float_intervalI[of x X p]
   by (auto simp: set_of'_def)
 
 lemma real_interval_abs_interval[simp]:
   "real_interval (abs_interval x) = abs_interval (real_interval x)"
   by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_max real_of_float_min)
 
 lift_definition floor_float_interval::"float interval \<Rightarrow> float interval" is
   "\<lambda>(l, u). (floor_fl l, floor_fl u)"
   by (auto intro!: floor_mono simp: floor_fl.rep_eq)
 
 lemma lower_floor_float_interval[simp]: "lower (floor_float_interval x) = floor_fl (lower x)"
   by transfer auto
 lemma upper_floor_float_interval[simp]: "upper (floor_float_interval x) = floor_fl (upper x)"
   by transfer auto
 
 lemma floor_float_intervalI: "\<lfloor>x\<rfloor> \<in>\<^sub>r floor_float_interval X" if "x \<in>\<^sub>r X"
   using that by (auto simp: set_of_eq floor_fl_def floor_mono)
 
 end
 
 
 subsection \<open>constants for code generation\<close>
 
 definition lowerF::"float interval \<Rightarrow> float" where "lowerF = lower"
 definition upperF::"float interval \<Rightarrow> float" where "upperF = upper"
 
 
 end
\ No newline at end of file
diff --git a/src/HOL/Library/Poly_Mapping.thy b/src/HOL/Library/Poly_Mapping.thy
--- a/src/HOL/Library/Poly_Mapping.thy
+++ b/src/HOL/Library/Poly_Mapping.thy
@@ -1,1878 +1,1878 @@
 (* Author: Andreas Lochbihler, ETH Zurich
    Author: Florian Haftmann, TU Muenchen
    with some material ported from HOL Light by LCP
 *)
 
 section \<open>Polynomial mapping: combination of almost everywhere zero functions with an algebraic view\<close>
 
 theory Poly_Mapping
 imports Groups_Big_Fun Fun_Lexorder More_List
 begin
 
 subsection \<open>Preliminary: auxiliary operations for \emph{almost everywhere zero}\<close>
 
 text \<open>
   A central notion for polynomials are functions being \emph{almost everywhere zero}.
   For these we provide some auxiliary definitions and lemmas.
 \<close>
 
 lemma finite_mult_not_eq_zero_leftI:
   fixes f :: "'b \<Rightarrow> 'a :: mult_zero"
   assumes "finite {a. f a \<noteq> 0}"
   shows "finite {a. g a * f a \<noteq> 0}"
 proof -
   have "{a. g a * f a \<noteq> 0} \<subseteq> {a. f a \<noteq> 0}" by auto
   then show ?thesis using assms by (rule finite_subset)
 qed
 
 lemma finite_mult_not_eq_zero_rightI:
   fixes f :: "'b \<Rightarrow> 'a :: mult_zero"
   assumes "finite {a. f a \<noteq> 0}"
   shows "finite {a. f a * g a \<noteq> 0}"
 proof -
   have "{a. f a * g a \<noteq> 0} \<subseteq> {a. f a \<noteq> 0}" by auto
   then show ?thesis using assms by (rule finite_subset)
 qed
 
 lemma finite_mult_not_eq_zero_prodI:
   fixes f g :: "'a \<Rightarrow> 'b::semiring_0"
   assumes "finite {a. f a \<noteq> 0}" (is "finite ?F")
   assumes "finite {b. g b \<noteq> 0}" (is "finite ?G")
   shows "finite {(a, b). f a * g b \<noteq> 0}"
 proof -
   from assms have "finite (?F \<times> ?G)"
     by blast
   then have "finite {(a, b). f a \<noteq> 0 \<and> g b \<noteq> 0}"
     by simp
   then show ?thesis
     by (rule rev_finite_subset) auto
 qed
 
 lemma finite_not_eq_zero_sumI:
   fixes f g :: "'a::monoid_add \<Rightarrow> 'b::semiring_0"
   assumes "finite {a. f a \<noteq> 0}" (is "finite ?F")
   assumes "finite {b. g b \<noteq> 0}" (is "finite ?G")
   shows "finite {a + b | a b. f a \<noteq> 0 \<and> g b \<noteq> 0}" (is "finite ?FG")
 proof -
   from assms have "finite (?F \<times> ?G)"
     by (simp add: finite_cartesian_product_iff)
   then have "finite (case_prod plus ` (?F \<times> ?G))"
     by (rule finite_imageI)
   also have "case_prod plus ` (?F \<times> ?G) = ?FG"
     by auto
   finally show ?thesis
     by simp
 qed
 
 lemma finite_mult_not_eq_zero_sumI:
   fixes f g :: "'a::monoid_add \<Rightarrow> 'b::semiring_0"
   assumes "finite {a. f a \<noteq> 0}"
   assumes "finite {b. g b \<noteq> 0}"
   shows "finite {a + b | a b. f a * g b \<noteq> 0}"
 proof -
   from assms
   have "finite {a + b | a b. f a \<noteq> 0 \<and> g b \<noteq> 0}"
     by (rule finite_not_eq_zero_sumI)
   then show ?thesis
     by (rule rev_finite_subset) (auto dest: mult_not_zero)
 qed
 
 lemma finite_Sum_any_not_eq_zero_weakenI:
   assumes "finite {a. \<exists>b. f a b \<noteq> 0}"
   shows "finite {a. Sum_any (f a) \<noteq> 0}"
 proof -
   have "{a. Sum_any (f a) \<noteq> 0} \<subseteq> {a. \<exists>b. f a b \<noteq> 0}"
     by (auto elim: Sum_any.not_neutral_obtains_not_neutral)
   then show ?thesis using assms by (rule finite_subset)
 qed
 
 context zero
 begin
 
 definition "when" :: "'a \<Rightarrow> bool \<Rightarrow> 'a" (infixl "when" 20)
 where
   "(a when P) = (if P then a else 0)"
 
 text \<open>
   Case distinctions always complicate matters, particularly when
   nested.  The @{const "when"} operation allows to minimise these
   if @{term 0} is the false-case value and makes proof obligations
   much more readable.
 \<close>
 
 lemma "when" [simp]:
   "P \<Longrightarrow> (a when P) = a"
   "\<not> P \<Longrightarrow> (a when P) = 0"
   by (simp_all add: when_def)
 
 lemma when_simps [simp]:
   "(a when True) = a"
   "(a when False) = 0"
   by simp_all
 
 lemma when_cong:
   assumes "P \<longleftrightarrow> Q"
     and "Q \<Longrightarrow> a = b"
   shows "(a when P) = (b when Q)"
   using assms by (simp add: when_def)
 
 lemma zero_when [simp]:
   "(0 when P) = 0"
   by (simp add: when_def)
 
 lemma when_when:
   "(a when P when Q) = (a when P \<and> Q)"
   by (cases Q) simp_all
 
 lemma when_commute:
   "(a when Q when P) = (a when P when Q)"
   by (simp add: when_when conj_commute)
 
 lemma when_neq_zero [simp]:
   "(a when P) \<noteq> 0 \<longleftrightarrow> P \<and> a \<noteq> 0"
   by (cases P) simp_all
 
 end
 
 context monoid_add
 begin
 
 lemma when_add_distrib:
   "(a + b when P) = (a when P) + (b when P)"
   by (simp add: when_def)
 
 end
 
 context semiring_1
 begin
 
 lemma zero_power_eq:
   "0 ^ n = (1 when n = 0)"
   by (simp add: power_0_left)
 
 end
 
 context comm_monoid_add
 begin
 
 lemma Sum_any_when_equal [simp]:
   "(\<Sum>a. (f a when a = b)) = f b"
   by (simp add: when_def)
 
 lemma Sum_any_when_equal' [simp]:
   "(\<Sum>a. (f a when b = a)) = f b"
   by (simp add: when_def)
 
 lemma Sum_any_when_independent:
   "(\<Sum>a. g a when P) = ((\<Sum>a. g a) when P)"
   by (cases P) simp_all
 
 lemma Sum_any_when_dependent_prod_right:
   "(\<Sum>(a, b). g a when b = h a) = (\<Sum>a. g a)"
 proof -
   have "inj_on (\<lambda>a. (a, h a)) {a. g a \<noteq> 0}"
     by (rule inj_onI) auto
   then show ?thesis unfolding Sum_any.expand_set
     by (rule sum.reindex_cong) auto
 qed
 
 lemma Sum_any_when_dependent_prod_left:
   "(\<Sum>(a, b). g b when a = h b) = (\<Sum>b. g b)"
 proof -
   have "(\<Sum>(a, b). g b when a = h b) = (\<Sum>(b, a). g b when a = h b)"
     by (rule Sum_any.reindex_cong [of prod.swap]) (simp_all add: fun_eq_iff)
   then show ?thesis by (simp add: Sum_any_when_dependent_prod_right)
 qed
 
 end
 
 context cancel_comm_monoid_add
 begin
 
 lemma when_diff_distrib:
   "(a - b when P) = (a when P) - (b when P)"
   by (simp add: when_def)
 
 end
 
 context group_add
 begin
 
 lemma when_uminus_distrib:
   "(- a when P) = - (a when P)"
   by (simp add: when_def)
 
 end
 
 context mult_zero
 begin
 
 lemma mult_when:
   "a * (b when P) = (a * b when P)"
   by (cases P) simp_all
 
 lemma when_mult:
   "(a when P) * b = (a * b when P)"
   by (cases P) simp_all
 
 end
 
 
 subsection \<open>Type definition\<close>
 
 text \<open>
   The following type is of central importance:
 \<close>
 
 typedef (overloaded) ('a, 'b) poly_mapping ("(_ \<Rightarrow>\<^sub>0 /_)" [1, 0] 0) =
   "{f :: 'a \<Rightarrow> 'b::zero. finite {x. f x \<noteq> 0}}"
   morphisms lookup Abs_poly_mapping
 proof -
   have "(\<lambda>_::'a. (0 :: 'b)) \<in> ?poly_mapping" by simp
   then show ?thesis by (blast intro!: exI)
 qed
 
 declare lookup_inverse [simp]
 declare lookup_inject [simp]
 
 lemma lookup_Abs_poly_mapping [simp]:
   "finite {x. f x \<noteq> 0} \<Longrightarrow> lookup (Abs_poly_mapping f) = f"
   using Abs_poly_mapping_inverse [of f] by simp
 
 lemma finite_lookup [simp]:
   "finite {k. lookup f k \<noteq> 0}"
   using poly_mapping.lookup [of f] by simp
 
 lemma finite_lookup_nat [simp]:
   fixes f :: "'a \<Rightarrow>\<^sub>0 nat"
   shows "finite {k. 0 < lookup f k}"
   using poly_mapping.lookup [of f] by simp
 
 lemma poly_mapping_eqI:
   assumes "\<And>k. lookup f k = lookup g k"
   shows "f = g"
   using assms unfolding poly_mapping.lookup_inject [symmetric]
   by blast
 
 lemma poly_mapping_eq_iff: "a = b \<longleftrightarrow> lookup a = lookup b"
   by auto
 
 text \<open>
   We model the universe of functions being \emph{almost everywhere zero}
   by means of a separate type @{typ "('a, 'b) poly_mapping"}.
   For convenience we provide a suggestive infix syntax which
   is a variant of the usual function space syntax.  Conversion between both types
   happens through the morphisms
   \begin{quote}
     @{term_type lookup}
   \end{quote}
   \begin{quote}
     @{term_type Abs_poly_mapping}
   \end{quote}
   satisfying
   \begin{quote}
     @{thm lookup_inverse}
   \end{quote}
   \begin{quote}
     @{thm lookup_Abs_poly_mapping}
   \end{quote}
   Luckily, we have rarely to deal with those low-level morphisms explicitly
   but rely on Isabelle's \emph{lifting} package with its method \<open>transfer\<close>
   and its specification tool \<open>lift_definition\<close>.
 \<close>
 
 setup_lifting type_definition_poly_mapping
 code_datatype Abs_poly_mapping\<comment>\<open>FIXME? workaround for preventing \<open>code_abstype\<close> setup\<close>
 
 text \<open>
   @{typ "'a \<Rightarrow>\<^sub>0 'b"} serves distinctive purposes:
   \begin{enumerate}
     \item A clever nesting as @{typ "(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a"}
       later in theory \<open>MPoly\<close> gives a suitable
       representation type for polynomials \emph{almost for free}:
       Interpreting @{typ "nat \<Rightarrow>\<^sub>0 nat"} as a mapping from variable identifiers
       to exponents yields monomials, and the whole type maps monomials
       to coefficients.  Lets call this the \emph{ultimate interpretation}.
     \item A further more specialised type isomorphic to @{typ "nat \<Rightarrow>\<^sub>0 'a"}
       is apt to direct implementation using code generation
       \cite{Haftmann-Nipkow:2010:code}.
   \end{enumerate}
   Note that despite the names \emph{mapping} and \emph{lookup} suggest something
   implementation-near, it is best to keep @{typ "'a \<Rightarrow>\<^sub>0 'b"} as an abstract
   \emph{algebraic} type
   providing operations like \emph{addition}, \emph{multiplication} without any notion
   of key-order, data structures etc.  This implementations-specific notions are
   easily introduced later for particular implementations but do not provide any
   gain for specifying logical properties of polynomials.
 \<close>
 
 subsection \<open>Additive structure\<close>
 
 text \<open>
   The additive structure covers the usual operations \<open>0\<close>, \<open>+\<close> and
   (unary and binary) \<open>-\<close>.  Recalling the ultimate interpretation, it
   is obvious that these have just lift the corresponding operations on values
   to mappings.
 
   Isabelle has a rich hierarchy of algebraic type classes, and in such situations
   of pointwise lifting a typical pattern is to have instantiations for a considerable
   number of type classes.
 
   The operations themselves are specified using \<open>lift_definition\<close>, where
   the proofs of the \emph{almost everywhere zero} property can be significantly involved.
 
   The @{const lookup} operation is supposed to be usable explicitly (unless in
   other situations where the morphisms between types are somehow internal
   to the \emph{lifting} package).  Hence it is good style to provide explicit rewrite
   rules how @{const lookup} acts on operations immediately.
 \<close>
 
 instantiation poly_mapping :: (type, zero) zero
 begin
 
 lift_definition zero_poly_mapping :: "'a \<Rightarrow>\<^sub>0 'b"
   is "\<lambda>k. 0"
   by simp
 
 instance ..
 
 end
 
 lemma Abs_poly_mapping [simp]: "Abs_poly_mapping (\<lambda>k. 0) = 0"
   by (simp add: zero_poly_mapping.abs_eq)
 
 lemma lookup_zero [simp]: "lookup 0 k = 0"
   by transfer rule
 
 instantiation poly_mapping :: (type, monoid_add) monoid_add
 begin
 
 lift_definition plus_poly_mapping ::
     "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b"
   is "\<lambda>f1 f2 k. f1 k + f2 k"
 proof -
   fix f1 f2 :: "'a \<Rightarrow> 'b"
   assume "finite {k. f1 k \<noteq> 0}"
     and "finite {k. f2 k \<noteq> 0}"
   then have "finite ({k. f1 k \<noteq> 0} \<union> {k. f2 k \<noteq> 0})" by auto
   moreover have "{x. f1 x + f2 x \<noteq> 0} \<subseteq> {k. f1 k \<noteq> 0} \<union> {k. f2 k \<noteq> 0}"
     by auto
   ultimately show "finite {x. f1 x + f2 x \<noteq> 0}"
     by (blast intro: finite_subset)
 qed
 
 instance
   by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+
 
 end
 
 lemma lookup_add:
   "lookup (f + g) k = lookup f k + lookup g k"
   by transfer rule
 
 instance poly_mapping :: (type, comm_monoid_add) comm_monoid_add
   by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+
 
 lemma lookup_sum: "lookup (sum pp X) i = sum (\<lambda>x. lookup (pp x) i) X"
   by (induction rule: infinite_finite_induct) (auto simp: lookup_add)
 
 (*instance poly_mapping :: (type, "{monoid_add, cancel_semigroup_add}") cancel_semigroup_add
   by intro_classes (transfer, simp add: fun_eq_iff)+*)
 
 instantiation poly_mapping :: (type, cancel_comm_monoid_add) cancel_comm_monoid_add
 begin
 
 lift_definition minus_poly_mapping :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b"
   is "\<lambda>f1 f2 k. f1 k - f2 k"
 proof -
   fix f1 f2 :: "'a \<Rightarrow> 'b"
   assume "finite {k. f1 k \<noteq> 0}"
     and "finite {k. f2 k \<noteq> 0}"
   then have "finite ({k. f1 k \<noteq> 0} \<union> {k. f2 k \<noteq> 0})" by auto
   moreover have "{x. f1 x - f2 x \<noteq> 0} \<subseteq> {k. f1 k \<noteq> 0} \<union> {k. f2 k \<noteq> 0}"
     by auto
   ultimately show "finite {x. f1 x - f2 x \<noteq> 0}" by (blast intro: finite_subset)
 qed
 
 instance
   by intro_classes (transfer, simp add: fun_eq_iff diff_diff_add)+
 
 end
 
 instantiation poly_mapping :: (type, ab_group_add) ab_group_add
 begin
 
 lift_definition uminus_poly_mapping :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b"
   is uminus
   by simp
 
 
 instance
   by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+
 
 end
 
 lemma lookup_uminus [simp]:
   "lookup (- f) k = - lookup f k"
   by transfer simp
 
 lemma lookup_minus:
   "lookup (f - g) k = lookup f k - lookup g k"
   by transfer rule
 
 
 subsection \<open>Multiplicative structure\<close>
 
 instantiation poly_mapping :: (zero, zero_neq_one) zero_neq_one
 begin
 
 lift_definition one_poly_mapping :: "'a \<Rightarrow>\<^sub>0 'b"
   is "\<lambda>k. 1 when k = 0"
   by simp
 
 instance
   by intro_classes (transfer, simp add: fun_eq_iff)
 
 end
 
 lemma lookup_one:
   "lookup 1 k = (1 when k = 0)"
   by transfer rule
 
 lemma lookup_one_zero [simp]:
   "lookup 1 0 = 1"
   by transfer simp
 
 definition prod_fun :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a::monoid_add \<Rightarrow> 'b::semiring_0"
 where
   "prod_fun f1 f2 k = (\<Sum>l. f1 l * (\<Sum>q. (f2 q when k = l + q)))"
 
 lemma prod_fun_unfold_prod:
   fixes f g :: "'a :: monoid_add \<Rightarrow> 'b::semiring_0"
   assumes fin_f: "finite {a. f a \<noteq> 0}"
   assumes fin_g: "finite {b. g b \<noteq> 0}"
   shows "prod_fun f g k = (\<Sum>(a, b). f a * g b when k = a + b)"
 proof -
   let ?C = "{a. f a \<noteq> 0} \<times> {b. g b \<noteq> 0}"
   from fin_f fin_g have "finite ?C" by blast
   moreover have "{a. \<exists>b. (f a * g b when k = a + b) \<noteq> 0} \<times>
     {b. \<exists>a. (f a * g b when k = a + b) \<noteq> 0} \<subseteq> {a. f a \<noteq> 0} \<times> {b. g b \<noteq> 0}"
     by auto
   ultimately show ?thesis using fin_g
     by (auto simp add: prod_fun_def
       Sum_any.cartesian_product [of "{a. f a \<noteq> 0} \<times> {b. g b \<noteq> 0}"] Sum_any_right_distrib mult_when)
 qed
 
 lemma finite_prod_fun:
   fixes f1 f2 :: "'a :: monoid_add \<Rightarrow> 'b :: semiring_0"
   assumes fin1: "finite {l. f1 l \<noteq> 0}"
   and fin2: "finite {q. f2 q \<noteq> 0}"
   shows "finite {k. prod_fun f1 f2 k \<noteq> 0}"
 proof -
   have *: "finite {k. (\<exists>l. f1 l \<noteq> 0 \<and> (\<exists>q. f2 q \<noteq> 0 \<and> k = l + q))}"
     using assms by simp
   { fix k l
     have "{q. (f2 q when k = l + q) \<noteq> 0} \<subseteq> {q. f2 q \<noteq> 0 \<and> k = l + q}" by auto
     with fin2 have "sum f2 {q. f2 q \<noteq> 0 \<and> k = l + q} = (\<Sum>q. (f2 q when k = l + q))"
       by (simp add: Sum_any.expand_superset [of "{q. f2 q \<noteq> 0 \<and> k = l + q}"]) }
   note aux = this
   have "{k. (\<Sum>l. f1 l * sum f2 {q. f2 q \<noteq> 0 \<and> k = l + q}) \<noteq> 0}
     \<subseteq> {k. (\<exists>l. f1 l * sum f2 {q. f2 q \<noteq> 0 \<and> k = l + q} \<noteq> 0)}"
     by (auto elim!: Sum_any.not_neutral_obtains_not_neutral)
   also have "\<dots> \<subseteq> {k. (\<exists>l. f1 l \<noteq> 0 \<and> sum f2 {q. f2 q \<noteq> 0 \<and> k = l + q} \<noteq> 0)}"
     by (auto dest: mult_not_zero)
   also have "\<dots> \<subseteq> {k. (\<exists>l. f1 l \<noteq> 0 \<and> (\<exists>q. f2 q \<noteq> 0 \<and> k = l + q))}"
     by (auto elim!: sum.not_neutral_contains_not_neutral)
   finally have "finite {k. (\<Sum>l. f1 l * sum f2 {q. f2 q \<noteq> 0 \<and> k = l + q}) \<noteq> 0}"
     using * by (rule finite_subset)
   with aux have "finite {k. (\<Sum>l. f1 l * (\<Sum>q. (f2 q when k = l + q))) \<noteq> 0}"
     by simp
   with fin2 show ?thesis
    by (simp add: prod_fun_def)
 qed
 
 instantiation poly_mapping :: (monoid_add, semiring_0) semiring_0
 begin
 
 lift_definition times_poly_mapping :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b"
   is prod_fun
 by(rule finite_prod_fun)
 
 instance
 proof
   fix a b c :: "'a \<Rightarrow>\<^sub>0 'b"
   show "a * b * c = a * (b * c)"
   proof transfer
     fix f g h :: "'a \<Rightarrow> 'b"
     assume fin_f: "finite {a. f a \<noteq> 0}" (is "finite ?F")
     assume fin_g: "finite {b. g b \<noteq> 0}" (is "finite ?G")
     assume fin_h: "finite {c. h c \<noteq> 0}" (is "finite ?H")
     from fin_f fin_g have fin_fg: "finite {(a, b). f a * g b \<noteq> 0}" (is "finite ?FG")
       by (rule finite_mult_not_eq_zero_prodI)
     from fin_g fin_h have fin_gh: "finite {(b, c). g b * h c \<noteq> 0}" (is "finite ?GH")
       by (rule finite_mult_not_eq_zero_prodI)
     from fin_f fin_g have fin_fg': "finite {a + b | a b. f a * g b \<noteq> 0}" (is "finite ?FG'")
       by (rule finite_mult_not_eq_zero_sumI)
     then have fin_fg'': "finite {d. (\<Sum>(a, b). f a * g b when d = a + b) \<noteq> 0}"
       by (auto intro: finite_Sum_any_not_eq_zero_weakenI)
     from fin_g fin_h have fin_gh': "finite {b + c | b c. g b * h c \<noteq> 0}" (is "finite ?GH'")
       by (rule finite_mult_not_eq_zero_sumI)
     then have fin_gh'': "finite {d. (\<Sum>(b, c). g b * h c when d = b + c) \<noteq> 0}"
       by (auto intro: finite_Sum_any_not_eq_zero_weakenI)
     show "prod_fun (prod_fun f g) h = prod_fun f (prod_fun g h)" (is "?lhs = ?rhs")
     proof
       fix k
       from fin_f fin_g fin_h fin_fg''
       have "?lhs k = (\<Sum>(ab, c). (\<Sum>(a, b). f a * g b when ab = a + b) * h c when k = ab + c)"
         by (simp add: prod_fun_unfold_prod)
       also have "\<dots> = (\<Sum>(ab, c). (\<Sum>(a, b). f a * g b * h c when k = ab + c when ab = a + b))"
         apply (subst Sum_any_left_distrib)
         using fin_fg apply (simp add: split_def)
         apply (subst Sum_any_when_independent [symmetric])
         apply (simp add: when_when when_mult mult_when split_def conj_commute)
         done
       also have "\<dots> = (\<Sum>(ab, c, a, b). f a * g b * h c when k = ab + c when ab = a + b)"
         apply (subst Sum_any.cartesian_product2 [of "(?FG' \<times> ?H) \<times> ?FG"])
         apply (auto simp add: finite_cartesian_product_iff fin_fg fin_fg' fin_h dest: mult_not_zero)
         done
       also have "\<dots> = (\<Sum>(ab, c, a, b). f a * g b * h c when k = a + b + c when ab = a + b)"
         by (rule Sum_any.cong) (simp add: split_def when_def)
       also have "\<dots> = (\<Sum>(ab, cab). (case cab of (c, a, b) \<Rightarrow> f a * g b * h c when k = a + b + c)
         when ab = (case cab of (c, a, b) \<Rightarrow> a + b))"
         by (simp add: split_def)
       also have "\<dots> = (\<Sum>(c, a, b). f a * g b * h c when k = a + b + c)"
         by (simp add: Sum_any_when_dependent_prod_left)
       also have "\<dots> = (\<Sum>(bc, cab). (case cab of (c, a, b) \<Rightarrow> f a * g b * h c when k = a + b + c)
         when bc = (case cab of (c, a, b) \<Rightarrow> b + c))"
         by (simp add: Sum_any_when_dependent_prod_left)
       also have "\<dots> = (\<Sum>(bc, c, a, b). f a * g b * h c when k = a + b + c when bc = b + c)"
         by (simp add: split_def)
       also have "\<dots> = (\<Sum>(bc, c, a, b). f a * g b * h c when bc = b + c when k = a + bc)"
         by (rule Sum_any.cong) (simp add: split_def when_def ac_simps)
       also have "\<dots> = (\<Sum>(a, bc, b, c). f a * g b * h c when bc = b + c when k = a + bc)"
       proof -
         have "bij (\<lambda>(a, d, b, c). (d, c, a, b))"
           by (auto intro!: bijI injI surjI [of _ "\<lambda>(d, c, a, b). (a, d, b, c)"] simp add: split_def)
         then show ?thesis
           by (rule Sum_any.reindex_cong) auto
       qed
       also have "\<dots> = (\<Sum>(a, bc). (\<Sum>(b, c). f a * g b * h c when bc = b + c when k = a + bc))"
         apply (subst Sum_any.cartesian_product2 [of "(?F \<times> ?GH') \<times> ?GH"])
         apply (auto simp add: finite_cartesian_product_iff fin_f fin_gh fin_gh' ac_simps dest: mult_not_zero)
         done
       also have "\<dots> = (\<Sum>(a, bc). f a * (\<Sum>(b, c). g b * h c when bc = b + c) when k = a + bc)"
         apply (subst Sum_any_right_distrib)
         using fin_gh apply (simp add: split_def)
         apply (subst Sum_any_when_independent [symmetric])
         apply (simp add: when_when when_mult mult_when split_def ac_simps)
         done
       also from fin_f fin_g fin_h fin_gh''
       have "\<dots> = ?rhs k"
         by (simp add: prod_fun_unfold_prod)
       finally show "?lhs k = ?rhs k" .
     qed
   qed
   show "(a + b) * c = a * c + b * c"
   proof transfer
     fix f g h :: "'a \<Rightarrow> 'b"
     assume fin_f: "finite {k. f k \<noteq> 0}"
     assume fin_g: "finite {k. g k \<noteq> 0}"
     assume fin_h: "finite {k. h k \<noteq> 0}"
     show "prod_fun (\<lambda>k. f k + g k) h = (\<lambda>k. prod_fun f h k + prod_fun g h k)"
       apply (rule ext)
       apply (auto simp add: prod_fun_def algebra_simps)
       apply (subst Sum_any.distrib)
       using fin_f fin_g apply (auto intro: finite_mult_not_eq_zero_rightI)
       done
   qed
   show "a * (b + c) = a * b + a * c"
   proof transfer
     fix f g h :: "'a \<Rightarrow> 'b"
     assume fin_f: "finite {k. f k \<noteq> 0}"
     assume fin_g: "finite {k. g k \<noteq> 0}"
     assume fin_h: "finite {k. h k \<noteq> 0}"
     show "prod_fun f (\<lambda>k. g k + h k) = (\<lambda>k. prod_fun f g k + prod_fun f h k)"
       apply (rule ext)
       apply (auto simp add: prod_fun_def Sum_any.distrib algebra_simps when_add_distrib)
       apply (subst Sum_any.distrib)
       apply (simp_all add: algebra_simps)
       apply (auto intro: fin_g fin_h)
       apply (subst Sum_any.distrib)
       apply (simp_all add: algebra_simps)
       using fin_f apply (rule finite_mult_not_eq_zero_rightI)
       using fin_f apply (rule finite_mult_not_eq_zero_rightI)
       done
   qed
   show "0 * a = 0"
     by transfer (simp add: prod_fun_def [abs_def])
   show "a * 0 = 0"
     by transfer (simp add: prod_fun_def [abs_def])
 qed
 
 end
 
 lemma lookup_mult:
   "lookup (f * g) k = (\<Sum>l. lookup f l * (\<Sum>q. lookup g q when k = l + q))"
   by transfer (simp add: prod_fun_def)
 
 instance poly_mapping :: (comm_monoid_add, comm_semiring_0) comm_semiring_0
 proof
   fix a b c :: "'a \<Rightarrow>\<^sub>0 'b"
   show "a * b = b * a"
   proof transfer
     fix f g :: "'a \<Rightarrow> 'b"
     assume fin_f: "finite {a. f a \<noteq> 0}"
     assume fin_g: "finite {b. g b \<noteq> 0}"
     show "prod_fun f g = prod_fun g f"
     proof
       fix k
       have fin1: "\<And>l. finite {a. (f a when k = l + a) \<noteq> 0}"
         using fin_f by auto
       have fin2: "\<And>l. finite {b. (g b when k = l + b) \<noteq> 0}"
         using fin_g by auto
       from fin_f fin_g have "finite {(a, b). f a \<noteq> 0 \<and> g b \<noteq> 0}" (is "finite ?AB")
         by simp
       show "prod_fun f g k = prod_fun g f k"
         apply (simp add: prod_fun_def)
         apply (subst Sum_any_right_distrib)
         apply (rule fin2)
         apply (subst Sum_any_right_distrib)
          apply (rule fin1)
         apply (subst Sum_any.swap [of ?AB])
         apply (fact \<open>finite ?AB\<close>)
         apply (auto simp add: mult_when ac_simps)
         done
     qed
   qed
   show "(a + b) * c = a * c + b * c"
   proof transfer
     fix f g h :: "'a \<Rightarrow> 'b"
     assume fin_f: "finite {k. f k \<noteq> 0}"
     assume fin_g: "finite {k. g k \<noteq> 0}"
     assume fin_h: "finite {k. h k \<noteq> 0}"
     show "prod_fun (\<lambda>k. f k + g k) h = (\<lambda>k. prod_fun f h k + prod_fun g h k)"
       apply (auto simp add: prod_fun_def fun_eq_iff algebra_simps)
       apply (subst Sum_any.distrib)
       using fin_f apply (rule finite_mult_not_eq_zero_rightI)
       using fin_g apply (rule finite_mult_not_eq_zero_rightI)
       apply simp_all
       done
   qed
 qed
 
 instance poly_mapping :: (monoid_add, semiring_0_cancel) semiring_0_cancel
   ..
 
 instance poly_mapping :: (comm_monoid_add, comm_semiring_0_cancel) comm_semiring_0_cancel
   ..
 
 instance poly_mapping :: (monoid_add, semiring_1) semiring_1
 proof
   fix a :: "'a \<Rightarrow>\<^sub>0 'b"
   show "1 * a = a"
     by transfer (simp add: prod_fun_def [abs_def] when_mult)
   show "a * 1 = a"
     apply transfer
     apply (simp add: prod_fun_def [abs_def] Sum_any_right_distrib Sum_any_left_distrib mult_when)
     apply (subst when_commute)
     apply simp
     done
 qed
 
 instance poly_mapping :: (comm_monoid_add, comm_semiring_1) comm_semiring_1
 proof
   fix a :: "'a \<Rightarrow>\<^sub>0 'b"
   show "1 * a = a"
     by transfer (simp add: prod_fun_def [abs_def])
 qed
 
 instance poly_mapping :: (monoid_add, semiring_1_cancel) semiring_1_cancel
   ..
 
 instance poly_mapping :: (monoid_add, ring) ring
   ..
 
 instance poly_mapping :: (comm_monoid_add, comm_ring) comm_ring
   ..
 
 instance poly_mapping :: (monoid_add, ring_1) ring_1
   ..
 
 instance poly_mapping :: (comm_monoid_add, comm_ring_1) comm_ring_1
   ..
 
 
 subsection \<open>Single-point mappings\<close>
 
 lift_definition single :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b::zero"
   is "\<lambda>k v k'. (v when k = k')"
   by simp
 
 lemma inj_single [iff]:
   "inj (single k)"
 proof (rule injI, transfer)
   fix k :: 'b and a b :: "'a::zero"
   assume "(\<lambda>k'. a when k = k') = (\<lambda>k'. b when k = k')"
   then have "(\<lambda>k'. a when k = k') k = (\<lambda>k'. b when k = k') k"
     by (rule arg_cong)
   then show "a = b" by simp
 qed
 
 lemma lookup_single:
   "lookup (single k v) k' = (v when k = k')"
   by transfer rule
 
 lemma lookup_single_eq [simp]:
   "lookup (single k v) k = v"
   by transfer simp
 
 lemma lookup_single_not_eq:
   "k \<noteq> k' \<Longrightarrow> lookup (single k v) k' = 0"
   by transfer simp
 
 lemma single_zero [simp]:
   "single k 0 = 0"
   by transfer simp
 
 lemma single_one [simp]:
   "single 0 1 = 1"
   by transfer simp
 
 lemma single_add:
   "single k (a + b) = single k a + single k b"
   by transfer (simp add: fun_eq_iff when_add_distrib)
 
 lemma single_uminus:
   "single k (- a) = - single k a"
   by transfer (simp add: fun_eq_iff when_uminus_distrib)
 
 lemma single_diff:
   "single k (a - b) = single k a - single k b"
   by transfer (simp add: fun_eq_iff when_diff_distrib)
 
 lemma single_numeral [simp]:
   "single 0 (numeral n) = numeral n"
   by (induct n) (simp_all only: numeral.simps numeral_add single_zero single_one single_add)
 
 lemma lookup_numeral:
   "lookup (numeral n) k = (numeral n when k = 0)"
 proof -
   have "lookup (numeral n) k = lookup (single 0 (numeral n)) k"
     by simp
   then show ?thesis unfolding lookup_single by simp
 qed
 
 lemma single_of_nat [simp]:
   "single 0 (of_nat n) = of_nat n"
   by (induct n) (simp_all add: single_add)
 
 lemma lookup_of_nat:
   "lookup (of_nat n) k = (of_nat n when k = 0)"
 proof -
   have "lookup (of_nat n) k = lookup (single 0 (of_nat n)) k"
     by simp
   then show ?thesis unfolding lookup_single by simp
 qed
 
 lemma of_nat_single:
   "of_nat = single 0 \<circ> of_nat"
   by (simp add: fun_eq_iff)
 
 lemma mult_single:
   "single k a * single l b = single (k + l) (a * b)"
 proof transfer
   fix k l :: 'a and a b :: 'b
   show "prod_fun (\<lambda>k'. a when k = k') (\<lambda>k'. b when l = k') = (\<lambda>k'. a * b when k + l = k')"
   proof
     fix k'
     have "prod_fun (\<lambda>k'. a when k = k') (\<lambda>k'. b when l = k') k' = (\<Sum>n. a * b when l = n when k' = k + n)"
       by (simp add: prod_fun_def Sum_any_right_distrib mult_when when_mult)
     also have "\<dots> = (\<Sum>n. a * b when k' = k + n when l = n)"
       by (simp add: when_when conj_commute)
     also have "\<dots> = (a * b when k' = k + l)"
       by simp
     also have "\<dots> = (a * b when k + l = k')"
       by (simp add: when_def)
     finally show "prod_fun (\<lambda>k'. a when k = k') (\<lambda>k'. b when l = k') k' =
       (\<lambda>k'. a * b when k + l = k') k'" .
   qed
 qed
 
 instance poly_mapping :: (monoid_add, semiring_char_0) semiring_char_0
   by intro_classes (auto intro: inj_compose inj_of_nat simp add: of_nat_single)
 
 instance poly_mapping :: (monoid_add, ring_char_0) ring_char_0
   ..
 
 lemma single_of_int [simp]:
   "single 0 (of_int k) = of_int k"
   by (cases k) (simp_all add: single_diff single_uminus)
 
 lemma lookup_of_int:
   "lookup (of_int l) k = (of_int l when k = 0)"
 proof -
   have "lookup (of_int l) k = lookup (single 0 (of_int l)) k"
     by simp
   then show ?thesis unfolding lookup_single by simp
 qed
 
 
 subsection \<open>Integral domains\<close>
 
 instance poly_mapping :: ("{ordered_cancel_comm_monoid_add, linorder}", semiring_no_zero_divisors) semiring_no_zero_divisors
   text \<open>The @{class "linorder"} constraint is a pragmatic device for the proof --- maybe it can be dropped\<close>
 proof
   fix f g :: "'a \<Rightarrow>\<^sub>0 'b"
   assume "f \<noteq> 0" and "g \<noteq> 0"
   then show "f * g \<noteq> 0"
   proof transfer
     fix f g :: "'a \<Rightarrow> 'b"
     define F where "F = {a. f a \<noteq> 0}"
     moreover define G where "G = {a. g a \<noteq> 0}"
     ultimately have [simp]:
       "\<And>a. f a \<noteq> 0 \<longleftrightarrow> a \<in> F"
       "\<And>b. g b \<noteq> 0 \<longleftrightarrow> b \<in> G"
       by simp_all
     assume "finite {a. f a \<noteq> 0}"
     then have [simp]: "finite F"
       by simp
     assume "finite {a. g a \<noteq> 0}"
     then have [simp]: "finite G"
       by simp
     assume "f \<noteq> (\<lambda>a. 0)"
     then obtain a where "f a \<noteq> 0"
       by (auto simp add: fun_eq_iff)
     assume "g \<noteq> (\<lambda>b. 0)"
     then obtain b where "g b \<noteq> 0"
       by (auto simp add: fun_eq_iff)
     from \<open>f a \<noteq> 0\<close> and \<open>g b \<noteq> 0\<close> have "F \<noteq> {}" and "G \<noteq> {}"
       by auto
     note Max_F = \<open>finite F\<close> \<open>F \<noteq> {}\<close>
     note Max_G = \<open>finite G\<close> \<open>G \<noteq> {}\<close>
     from Max_F and Max_G have [simp]:
       "Max F \<in> F"
       "Max G \<in> G"
       by auto
     from Max_F Max_G have [dest!]:
       "\<And>a. a \<in> F \<Longrightarrow> a \<le> Max F"
       "\<And>b. b \<in> G \<Longrightarrow> b \<le> Max G"
       by auto
     define q where "q = Max F + Max G"
     have "(\<Sum>(a, b). f a * g b when q = a + b) =
       (\<Sum>(a, b). f a * g b when q = a + b when a \<in> F \<and> b \<in> G)"
       by (rule Sum_any.cong) (auto simp add: split_def when_def q_def intro: ccontr)
     also have "\<dots> =
       (\<Sum>(a, b). f a * g b when (Max F, Max G) = (a, b))"
     proof (rule Sum_any.cong)
       fix ab :: "'a \<times> 'a"
       obtain a b where [simp]: "ab = (a, b)"
         by (cases ab) simp_all
       have [dest!]:
         "a \<le> Max F \<Longrightarrow> Max F \<noteq> a \<Longrightarrow> a < Max F"
         "b \<le> Max G \<Longrightarrow> Max G \<noteq> b \<Longrightarrow> b < Max G"
         by auto
       show "(case ab of (a, b) \<Rightarrow> f a * g b when q = a + b when a \<in> F \<and> b \<in> G) =
          (case ab of (a, b) \<Rightarrow> f a * g b when (Max F, Max G) = (a, b))"
         by (auto simp add: split_def when_def q_def dest: add_strict_mono [of a "Max F" b "Max G"])
     qed
     also have "\<dots> = (\<Sum>ab. (case ab of (a, b) \<Rightarrow> f a * g b) when
       (Max F, Max G) = ab)"
       unfolding split_def when_def by auto
     also have "\<dots> \<noteq> 0"
       by simp
     finally have "prod_fun f g q \<noteq> 0"
       by (simp add: prod_fun_unfold_prod)
     then show "prod_fun f g \<noteq> (\<lambda>k. 0)"
       by (auto simp add: fun_eq_iff)
   qed
 qed
 
 instance poly_mapping :: ("{ordered_cancel_comm_monoid_add, linorder}", ring_no_zero_divisors) ring_no_zero_divisors
   ..
 
 instance poly_mapping :: ("{ordered_cancel_comm_monoid_add, linorder}", ring_1_no_zero_divisors) ring_1_no_zero_divisors
   ..
 
 instance poly_mapping :: ("{ordered_cancel_comm_monoid_add, linorder}", idom) idom
   ..
 
 
 subsection \<open>Mapping order\<close>
 
 instantiation poly_mapping :: (linorder, "{zero, linorder}") linorder
 begin
 
 lift_definition less_poly_mapping :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> bool"
   is less_fun
   .
 
 lift_definition less_eq_poly_mapping :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> bool"
   is "\<lambda>f g. less_fun f g \<or> f = g"
   .
 
 instance proof (rule class.Orderings.linorder.of_class.intro)
   show "class.linorder (less_eq :: (_ \<Rightarrow>\<^sub>0 _) \<Rightarrow> _) less"
   proof (rule linorder_strictI, rule order_strictI)
     fix f g h :: "'a \<Rightarrow>\<^sub>0 'b"
     show "f \<le> g \<longleftrightarrow> f < g \<or> f = g"
       by transfer (rule refl)
     show "\<not> f < f"
       by transfer (rule less_fun_irrefl)
     show "f < g \<or> f = g \<or> g < f"
     proof transfer
       fix f g :: "'a \<Rightarrow> 'b"
       assume "finite {k. f k \<noteq> 0}" and "finite {k. g k \<noteq> 0}"
       then have "finite ({k. f k \<noteq> 0} \<union> {k. g k \<noteq> 0})"
         by simp
       moreover have "{k. f k \<noteq> g k} \<subseteq> {k. f k \<noteq> 0} \<union> {k. g k \<noteq> 0}"
         by auto
       ultimately have "finite {k. f k \<noteq> g k}"
         by (rule rev_finite_subset)
       then show "less_fun f g \<or> f = g \<or> less_fun g f"
         by (rule less_fun_trichotomy)
     qed
     assume "f < g" then show "\<not> g < f"
       by transfer (rule less_fun_asym)
     note \<open>f < g\<close> moreover assume "g < h"
       ultimately show "f < h"
       by transfer (rule less_fun_trans)
   qed
 qed
 
 end
 
 instance poly_mapping :: (linorder, "{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le, linorder}") ordered_ab_semigroup_add
 proof (intro_classes, transfer)
   fix f g h :: "'a \<Rightarrow> 'b"
   assume *: "less_fun f g \<or> f = g"
   { assume "less_fun f g"
     then obtain k where "f k < g k" "(\<And>k'. k' < k \<Longrightarrow> f k' = g k')"
       by (blast elim!: less_funE)
     then have "h k + f k < h k + g k" "(\<And>k'. k' < k \<Longrightarrow> h k' + f k' = h k' + g k')"
       by simp_all
     then have "less_fun (\<lambda>k. h k + f k) (\<lambda>k. h k + g k)"
       by (blast intro: less_funI)
   }
   with * show "less_fun (\<lambda>k. h k + f k) (\<lambda>k. h k + g k) \<or> (\<lambda>k. h k + f k) = (\<lambda>k. h k + g k)"
     by (auto simp add: fun_eq_iff)
 qed
 
 instance poly_mapping :: (linorder, "{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le, cancel_comm_monoid_add, linorder}") linordered_cancel_ab_semigroup_add
   ..
 
 instance poly_mapping :: (linorder, "{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le, cancel_comm_monoid_add, linorder}") ordered_comm_monoid_add
   ..
 
 instance poly_mapping :: (linorder, "{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le, cancel_comm_monoid_add, linorder}") ordered_cancel_comm_monoid_add
   ..
 
 instance poly_mapping :: (linorder, linordered_ab_group_add) linordered_ab_group_add
   ..
 
 text \<open>
   For pragmatism we leave out the final elements in the hierarchy:
   @{class linordered_ring}, @{class linordered_ring_strict}, @{class linordered_idom};
   remember that the order instance is a mere technical device, not a deeper algebraic
   property.
 \<close>
 
 
 subsection \<open>Fundamental mapping notions\<close>
 
 lift_definition keys :: "('a \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'a set"
   is "\<lambda>f. {k. f k \<noteq> 0}" .
 
 lift_definition range :: "('a \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'b set"
   is "\<lambda>f :: 'a \<Rightarrow> 'b. Set.range f - {0}" .
 
 lemma finite_keys [simp]:
   "finite (keys f)"
   by transfer
 
 lemma not_in_keys_iff_lookup_eq_zero:
   "k \<notin> keys f \<longleftrightarrow> lookup f k = 0"
   by transfer simp
 
 lemma lookup_not_eq_zero_eq_in_keys:
   "lookup f k \<noteq> 0 \<longleftrightarrow> k \<in> keys f"
   by transfer simp
 
 lemma lookup_eq_zero_in_keys_contradict [dest]:
   "lookup f k = 0 \<Longrightarrow> \<not> k \<in> keys f"
   by (simp add: not_in_keys_iff_lookup_eq_zero)
 
 lemma finite_range [simp]: "finite (Poly_Mapping.range p)"
 proof transfer
   fix f :: "'b \<Rightarrow> 'a"
   assume *: "finite {x. f x \<noteq> 0}"
   have "Set.range f - {0} \<subseteq> f ` {x. f x \<noteq> 0}"
     by auto
   thus "finite (Set.range f - {0})"
     by(rule finite_subset)(rule finite_imageI[OF *])
 qed
 
 lemma in_keys_lookup_in_range [simp]:
   "k \<in> keys f \<Longrightarrow> lookup f k \<in> range f"
   by transfer simp
 
 lemma in_keys_iff: "x \<in> (keys s) = (lookup s x \<noteq> 0)"
   by (transfer, simp)
 
 lemma keys_zero [simp]:
   "keys 0 = {}"
   by transfer simp
 
 lemma range_zero [simp]:
   "range 0 = {}"
   by transfer auto
 
 lemma keys_add:
   "keys (f + g) \<subseteq> keys f \<union> keys g"
   by transfer auto
 
 lemma keys_one [simp]:
   "keys 1 = {0}"
   by transfer simp
 
 lemma range_one [simp]:
   "range 1 = {1}"
   by transfer (auto simp add: when_def)
 
 lemma keys_single [simp]:
   "keys (single k v) = (if v = 0 then {} else {k})"
   by transfer simp
 
 lemma range_single [simp]:
   "range (single k v) = (if v = 0 then {} else {v})"
   by transfer (auto simp add: when_def)
 
 lemma keys_mult:
   "keys (f * g) \<subseteq> {a + b | a b. a \<in> keys f \<and> b \<in> keys g}"
   apply transfer
   apply (auto simp add: prod_fun_def dest!: mult_not_zero elim!: Sum_any.not_neutral_obtains_not_neutral)
   apply blast
   done
 
 lemma setsum_keys_plus_distrib:
   assumes hom_0: "\<And>k. f k 0 = 0"
   and hom_plus: "\<And>k. k \<in> Poly_Mapping.keys p \<union> Poly_Mapping.keys q \<Longrightarrow> f k (Poly_Mapping.lookup p k + Poly_Mapping.lookup q k) = f k (Poly_Mapping.lookup p k) + f k (Poly_Mapping.lookup q k)"
   shows
   "(\<Sum>k\<in>Poly_Mapping.keys (p + q). f k (Poly_Mapping.lookup (p + q) k)) =
    (\<Sum>k\<in>Poly_Mapping.keys p. f k (Poly_Mapping.lookup p k)) +
    (\<Sum>k\<in>Poly_Mapping.keys q. f k (Poly_Mapping.lookup q k))"
   (is "?lhs = ?p + ?q")
 proof -
   let ?A = "Poly_Mapping.keys p \<union> Poly_Mapping.keys q"
   have "?lhs = (\<Sum>k\<in>?A. f k (Poly_Mapping.lookup p k + Poly_Mapping.lookup q k))"
     apply(rule sum.mono_neutral_cong_left)
        apply(simp_all add: Poly_Mapping.keys_add)
      apply(transfer fixing: f)
      apply(auto simp add: hom_0)[1]
     apply(transfer fixing: f)
     apply(auto simp add: hom_0)[1]
     done
   also have "\<dots> = (\<Sum>k\<in>?A. f k (Poly_Mapping.lookup p k) + f k (Poly_Mapping.lookup q k))"
     by(rule sum.cong)(simp_all add: hom_plus)
   also have "\<dots> = (\<Sum>k\<in>?A. f k (Poly_Mapping.lookup p k)) + (\<Sum>k\<in>?A. f k (Poly_Mapping.lookup q k))"
     (is "_ = ?p' + ?q'")
     by(simp add: sum.distrib)
   also have "?p' = ?p"
     by (simp add: hom_0 in_keys_iff sum.mono_neutral_cong_right)
   also have "?q' = ?q"
     by (simp add: hom_0 in_keys_iff sum.mono_neutral_cong_right)
   finally show ?thesis .
 qed
 
 subsection \<open>Degree\<close>
 
 definition degree :: "(nat \<Rightarrow>\<^sub>0 'a::zero) \<Rightarrow> nat"
 where
   "degree f = Max (insert 0 (Suc ` keys f))"
 
 lemma degree_zero [simp]:
   "degree 0 = 0"
   unfolding degree_def by transfer simp
 
 lemma degree_one [simp]:
   "degree 1 = 1"
   unfolding degree_def by transfer simp
 
 lemma degree_single_zero [simp]:
   "degree (single k 0) = 0"
   unfolding degree_def by transfer simp
 
 lemma degree_single_not_zero [simp]:
   "v \<noteq> 0 \<Longrightarrow> degree (single k v) = Suc k"
   unfolding degree_def by transfer simp
 
 lemma degree_zero_iff [simp]:
   "degree f = 0 \<longleftrightarrow> f = 0"
 unfolding degree_def proof transfer
   fix f :: "nat \<Rightarrow> 'a"
   assume "finite {n. f n \<noteq> 0}"
   then have fin: "finite (insert 0 (Suc ` {n. f n \<noteq> 0}))" by auto
   show "Max (insert 0 (Suc ` {n. f n \<noteq> 0})) = 0 \<longleftrightarrow> f = (\<lambda>n. 0)" (is "?P \<longleftrightarrow> ?Q")
   proof
     assume ?P
     have "{n. f n \<noteq> 0} = {}"
     proof (rule ccontr)
       assume "{n. f n \<noteq> 0} \<noteq> {}"
       then obtain n where "n \<in> {n. f n \<noteq> 0}" by blast
       then have "{n. f n \<noteq> 0} = insert n {n. f n \<noteq> 0}" by auto
       then have "Suc ` {n. f n \<noteq> 0} = insert (Suc n) (Suc ` {n. f n \<noteq> 0})" by auto
       with \<open>?P\<close> have "Max (insert 0 (insert (Suc n) (Suc ` {n. f n \<noteq> 0}))) = 0" by simp
       then have "Max (insert (Suc n) (insert 0 (Suc ` {n. f n \<noteq> 0}))) = 0"
         by (simp add: insert_commute)
       with fin have "max (Suc n) (Max (insert 0 (Suc ` {n. f n \<noteq> 0}))) = 0"
         by simp
       then show False by simp
     qed
     then show ?Q by (simp add: fun_eq_iff)
   next
     assume ?Q then show ?P by simp
   qed
 qed
 
 lemma degree_greater_zero_in_keys:
   assumes "0 < degree f"
   shows "degree f - 1 \<in> keys f"
 proof -
   from assms have "keys f \<noteq> {}"
     by (auto simp add: degree_def)
   then show ?thesis unfolding degree_def
     by (simp add: mono_Max_commute [symmetric] mono_Suc)
 qed
 
 lemma in_keys_less_degree:
   "n \<in> keys f \<Longrightarrow> n < degree f"
 unfolding degree_def by transfer (auto simp add: Max_gr_iff)
 
 lemma beyond_degree_lookup_zero:
   "degree f \<le> n \<Longrightarrow> lookup f n = 0"
   unfolding degree_def by transfer auto
 
 lemma degree_add:
   "degree (f + g) \<le> max (degree f) (Poly_Mapping.degree g)"
 unfolding degree_def proof transfer
   fix f g :: "nat \<Rightarrow> 'a"
   assume f: "finite {x. f x \<noteq> 0}"
   assume g: "finite {x. g x \<noteq> 0}"
   let ?f = "Max (insert 0 (Suc ` {k. f k \<noteq> 0}))"
   let ?g = "Max (insert 0 (Suc ` {k. g k \<noteq> 0}))"
   have "Max (insert 0 (Suc ` {k. f k + g k \<noteq> 0})) \<le> Max (insert 0 (Suc ` ({k. f k \<noteq> 0} \<union> {k. g k \<noteq> 0})))"
     by (rule Max.subset_imp) (insert f g, auto)
   also have "\<dots> = max ?f ?g"
     using f g by (simp_all add: image_Un Max_Un [symmetric])
   finally show "Max (insert 0 (Suc ` {k. f k + g k \<noteq> 0}))
     \<le> max (Max (insert 0 (Suc ` {k. f k \<noteq> 0}))) (Max (insert 0 (Suc ` {k. g k \<noteq> 0})))"
     .
 qed
 
 lemma sorted_list_of_set_keys:
   "sorted_list_of_set (keys f) = filter (\<lambda>k. k \<in> keys f) [0..<degree f]" (is "_ = ?r")
 proof -
   have "keys f = set ?r"
     by (auto dest: in_keys_less_degree)
   moreover have "sorted_list_of_set (set ?r) = ?r"
     unfolding sorted_list_of_set_sort_remdups
     by (simp add: remdups_filter filter_sort [symmetric])
   ultimately show ?thesis by simp
 qed
 
 
 subsection \<open>Inductive structure\<close>
 
 lift_definition update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b"
   is "\<lambda>k v f. f(k := v)"
 proof -
   fix f :: "'a \<Rightarrow> 'b" and k' v
   assume "finite {k. f k \<noteq> 0}"
   then have "finite (insert k' {k. f k \<noteq> 0})"
     by simp
   then show "finite {k. (f(k' := v)) k \<noteq> 0}"
     by (rule rev_finite_subset) auto
 qed
 
 lemma update_induct [case_names const update]:
   assumes const': "P 0"
   assumes update': "\<And>f a b. a \<notin> keys f \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> P f \<Longrightarrow> P (update a b f)"
   shows "P f"
 proof -
   obtain g where "f = Abs_poly_mapping g" and "finite {a. g a \<noteq> 0}"
     by (cases f) simp_all
   define Q where "Q g = P (Abs_poly_mapping g)" for g
   from \<open>finite {a. g a \<noteq> 0}\<close> have "Q g"
   proof (induct g rule: finite_update_induct)
     case const with const' Q_def show ?case
       by simp
   next
     case (update a b g)
     from \<open>finite {a. g a \<noteq> 0}\<close> \<open>g a = 0\<close> have "a \<notin> keys (Abs_poly_mapping g)"
       by (simp add: Abs_poly_mapping_inverse keys.rep_eq)
     moreover note \<open>b \<noteq> 0\<close>
     moreover from \<open>Q g\<close> have "P (Abs_poly_mapping g)"
       by (simp add: Q_def)
     ultimately have "P (update a b (Abs_poly_mapping g))"
       by (rule update')
     also from \<open>finite {a. g a \<noteq> 0}\<close>
     have "update a b (Abs_poly_mapping g) = Abs_poly_mapping (g(a := b))"
       by (simp add: update.abs_eq eq_onp_same_args)
     finally show ?case
       by (simp add: Q_def fun_upd_def)
   qed
   then show ?thesis by (simp add: Q_def \<open>f = Abs_poly_mapping g\<close>)
 qed
 
 lemma lookup_update:
   "lookup (update k v f) k' = (if k = k' then v else lookup f k')"
   by transfer simp
 
 lemma keys_update:
   "keys (update k v f) = (if v = 0 then keys f - {k} else insert k (keys f))"
   by transfer auto
 
 
 subsection \<open>Quasi-functorial structure\<close>
 
 lift_definition map :: "('b::zero \<Rightarrow> 'c::zero)
   \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'c::zero)"
   is "\<lambda>g f k. g (f k) when f k \<noteq> 0"
   by simp
 
 context
   fixes f :: "'b \<Rightarrow> 'a"
   assumes inj_f: "inj f"
 begin
 
 lift_definition map_key :: "('a \<Rightarrow>\<^sub>0 'c::zero) \<Rightarrow> 'b \<Rightarrow>\<^sub>0 'c"
   is "\<lambda>p. p \<circ> f"
 proof -
   fix g :: "'c \<Rightarrow> 'd" and p :: "'a \<Rightarrow> 'c"
   assume "finite {x. p x \<noteq> 0}"
   hence "finite (f ` {y. p (f y) \<noteq> 0})"
     by(rule finite_subset[rotated]) auto
   thus "finite {x. (p \<circ> f) x \<noteq> 0}" unfolding o_def
     by(rule finite_imageD)(rule subset_inj_on[OF inj_f], simp)
 qed
 
 end
 
 lemma map_key_compose:
   assumes [transfer_rule]: "inj f" "inj g"
   shows "map_key f (map_key g p) = map_key (g \<circ> f) p"
 proof -
   from assms have [transfer_rule]: "inj (g \<circ> f)"
     by(simp add: inj_compose)
   show ?thesis by transfer(simp add: o_assoc)
 qed
 
 lemma map_key_id:
   "map_key (\<lambda>x. x) p = p"
 proof -
   have [transfer_rule]: "inj (\<lambda>x. x)" by simp
   show ?thesis by transfer(simp add: o_def)
 qed
 
 context
   fixes f :: "'a \<Rightarrow> 'b"
   assumes inj_f [transfer_rule]: "inj f"
 begin
 
 lemma map_key_map:
   "map_key f (map g p) = map g (map_key f p)"
   by transfer (simp add: fun_eq_iff)
 
 lemma map_key_plus:
   "map_key f (p + q) = map_key f p + map_key f q"
   by transfer (simp add: fun_eq_iff)
 
 lemma keys_map_key:
   "keys (map_key f p) = f -` keys p"
   by transfer auto
 
 lemma map_key_zero [simp]:
   "map_key f 0 = 0"
   by transfer (simp add: fun_eq_iff)
 
 lemma map_key_single [simp]:
   "map_key f (single (f k) v) = single k v"
   by transfer (simp add: fun_eq_iff inj_onD [OF inj_f] when_def)
 
 end
 
 lemma mult_map_scale_conv_mult: "map ((*) s) p = single 0 s * p"
 proof(transfer fixing: s)
   fix p :: "'a \<Rightarrow> 'b"
   assume *: "finite {x. p x \<noteq> 0}"
   { fix x
     have "prod_fun (\<lambda>k'. s when 0 = k') p x =
           (\<Sum>l :: 'a. if l = 0 then s * (\<Sum>q. p q when x = q) else 0)"
       by(auto simp add: prod_fun_def when_def intro: Sum_any.cong simp del: Sum_any.delta)
     also have "\<dots> = (\<lambda>k. s * p k when p k \<noteq> 0) x" by(simp add: when_def)
     also note calculation }
   then show "(\<lambda>k. s * p k when p k \<noteq> 0) = prod_fun (\<lambda>k'. s when 0 = k') p"
     by(simp add: fun_eq_iff)
 qed
 
 lemma map_single [simp]:
   "(c = 0 \<Longrightarrow> f 0 = 0) \<Longrightarrow> map f (single x c) = single x (f c)"
 by transfer(auto simp add: fun_eq_iff when_def)
 
 lemma map_eq_zero_iff: "map f p = 0 \<longleftrightarrow> (\<forall>k \<in> keys p. f (lookup p k) = 0)"
 by transfer(auto simp add: fun_eq_iff when_def)
 
 subsection \<open>Canonical dense representation of @{typ "nat \<Rightarrow>\<^sub>0 'a"}\<close>
 
 abbreviation no_trailing_zeros :: "'a :: zero list \<Rightarrow> bool"
 where
   "no_trailing_zeros \<equiv> no_trailing ((=) 0)"
 
 lift_definition "nth" :: "'a list \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a::zero)"
   is "nth_default 0"
   by (fact finite_nth_default_neq_default)
 
 text \<open>
   The opposite direction is directly specified on (later)
   type \<open>nat_mapping\<close>.
 \<close>
 
 lemma nth_Nil [simp]:
   "nth [] = 0"
   by transfer (simp add: fun_eq_iff)
 
 lemma nth_singleton [simp]:
   "nth [v] = single 0 v"
 proof (transfer, rule ext)
   fix n :: nat and v :: 'a
   show "nth_default 0 [v] n = (v when 0 = n)"
     by (auto simp add: nth_default_def nth_append)
 qed
 
 lemma nth_replicate [simp]:
   "nth (replicate n 0 @ [v]) = single n v"
 proof (transfer, rule ext)
   fix m n :: nat and v :: 'a
   show "nth_default 0 (replicate n 0 @ [v]) m = (v when n = m)"
     by (auto simp add: nth_default_def nth_append)
 qed
 
 lemma nth_strip_while [simp]:
   "nth (strip_while ((=) 0) xs) = nth xs"
   by transfer (fact nth_default_strip_while_dflt)
 
 lemma nth_strip_while' [simp]:
   "nth (strip_while (\<lambda>k. k = 0) xs) = nth xs"
   by (subst eq_commute) (fact nth_strip_while)
 
 lemma nth_eq_iff:
   "nth xs = nth ys \<longleftrightarrow> strip_while (HOL.eq 0) xs = strip_while (HOL.eq 0) ys"
   by transfer (simp add: nth_default_eq_iff)
 
 lemma lookup_nth [simp]:
   "lookup (nth xs) = nth_default 0 xs"
   by (fact nth.rep_eq)
 
 lemma keys_nth [simp]:
   "keys (nth xs) =  fst ` {(n, v) \<in> set (enumerate 0 xs). v \<noteq> 0}"
 proof transfer
   fix xs :: "'a list"
   { fix n
     assume "nth_default 0 xs n \<noteq> 0"
     then have "n < length xs" and "xs ! n \<noteq> 0"
       by (auto simp add: nth_default_def split: if_splits)
     then have "(n, xs ! n) \<in> {(n, v). (n, v) \<in> set (enumerate 0 xs) \<and> v \<noteq> 0}" (is "?x \<in> ?A")
       by (auto simp add: in_set_conv_nth enumerate_eq_zip)
     then have "fst ?x \<in> fst ` ?A"
       by blast
     then have "n \<in> fst ` {(n, v). (n, v) \<in> set (enumerate 0 xs) \<and> v \<noteq> 0}"
       by simp
   }
   then show "{k. nth_default 0 xs k \<noteq> 0} = fst ` {(n, v). (n, v) \<in> set (enumerate 0 xs) \<and> v \<noteq> 0}"
     by (auto simp add: in_enumerate_iff_nth_default_eq)
 qed
 
 lemma range_nth [simp]:
   "range (nth xs) = set xs - {0}"
   by transfer simp
 
 lemma degree_nth:
   "no_trailing_zeros xs \<Longrightarrow> degree (nth xs) = length xs"
 unfolding degree_def proof transfer
   fix xs :: "'a list"
   assume *: "no_trailing_zeros xs"
   let ?A = "{n. nth_default 0 xs n \<noteq> 0}"
   let ?f = "nth_default 0 xs"
   let ?bound = "Max (insert 0 (Suc ` {n. ?f n \<noteq> 0}))"
   show "?bound = length xs"
   proof (cases "xs = []")
     case False
     with * obtain n where n: "n < length xs" "xs ! n \<noteq> 0"
       by (fastforce simp add: no_trailing_unfold last_conv_nth neq_Nil_conv)
     then have "?bound = Max (Suc ` {k. (k < length xs \<longrightarrow> xs ! k \<noteq> (0::'a)) \<and> k < length xs})"
       by (subst Max_insert) (auto simp add: nth_default_def)
     also let ?A = "{k. k < length xs \<and> xs ! k \<noteq> 0}"
     have "{k. (k < length xs \<longrightarrow> xs ! k \<noteq> (0::'a)) \<and> k < length xs} = ?A" by auto
     also have "Max (Suc ` ?A) = Suc (Max ?A)" using n
       by (subst mono_Max_commute [where f = Suc, symmetric]) (auto simp add: mono_Suc)
     also {
       have "Max ?A \<in> ?A" using n Max_in [of ?A] by fastforce
       hence "Suc (Max ?A) \<le> length xs" by simp
       moreover from * False have "length xs - 1 \<in> ?A"
         by(auto simp add: no_trailing_unfold last_conv_nth)
       hence "length xs - 1 \<le> Max ?A" using Max_ge[of ?A "length xs - 1"] by auto
       hence "length xs \<le> Suc (Max ?A)" by simp
       ultimately have "Suc (Max ?A) = length xs" by simp }
     finally show ?thesis .
   qed simp
 qed
 
 lemma nth_trailing_zeros [simp]:
   "nth (xs @ replicate n 0) = nth xs"
   by transfer simp
 
 lemma nth_idem:
   "nth (List.map (lookup f) [0..<degree f]) = f"
   unfolding degree_def by transfer
     (auto simp add: nth_default_def fun_eq_iff not_less)
 
 lemma nth_idem_bound:
   assumes "degree f \<le> n"
   shows "nth (List.map (lookup f) [0..<n]) = f"
 proof -
   from assms obtain m where "n = degree f + m"
     by (blast dest: le_Suc_ex)
   then have "[0..<n] = [0..<degree f] @ [degree f..<degree f + m]"
     by (simp add: upt_add_eq_append [of 0])
   moreover have "List.map (lookup f) [degree f..<degree f + m] = replicate m 0"
     by (rule replicate_eqI) (auto simp add: beyond_degree_lookup_zero)
   ultimately show ?thesis by (simp add: nth_idem)
 qed
 
 
 subsection \<open>Canonical sparse representation of @{typ "'a \<Rightarrow>\<^sub>0 'b"}\<close>
 
 lift_definition the_value :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b::zero"
   is "\<lambda>xs k. case map_of xs k of None \<Rightarrow> 0 | Some v \<Rightarrow> v"
 proof -
   fix xs :: "('a \<times> 'b) list"
   have fin: "finite {k. \<exists>v. map_of xs k = Some v}"
     using finite_dom_map_of [of xs] unfolding dom_def by auto
   then show "finite {k. (case map_of xs k of None \<Rightarrow> 0 | Some v \<Rightarrow> v) \<noteq> 0}"
     using fin by (simp split: option.split)
 qed
 
 definition items :: "('a::linorder \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> ('a \<times> 'b) list"
 where
   "items f = List.map (\<lambda>k. (k, lookup f k)) (sorted_list_of_set (keys f))"
 
 text \<open>
   For the canonical sparse representation we provide both
   directions of morphisms since the specification of
   ordered association lists in theory \<open>OAList\<close>
   will support arbitrary linear orders @{class linorder}
   as keys, not just natural numbers @{typ nat}.
 \<close>
 
 lemma the_value_items [simp]:
   "the_value (items f) = f"
   unfolding items_def
   by transfer (simp add: fun_eq_iff map_of_map_restrict restrict_map_def)
 
 lemma lookup_the_value:
   "lookup (the_value xs) k = (case map_of xs k of None \<Rightarrow> 0 | Some v \<Rightarrow> v)"
   by transfer rule
 
 lemma items_the_value:
   assumes "sorted (List.map fst xs)" and "distinct (List.map fst xs)" and "0 \<notin> snd ` set xs"
   shows "items (the_value xs) = xs"
 proof -
   from assms have "sorted_list_of_set (set (List.map fst xs)) = List.map fst xs"
     unfolding sorted_list_of_set_sort_remdups by (simp add: distinct_remdups_id sorted_sort_id)
   moreover from assms have "keys (the_value xs) = fst ` set xs"
     by transfer (auto simp add: image_def split: option.split dest: set_map_of_compr)
   ultimately show ?thesis
     unfolding items_def using assms
     by (auto simp add: lookup_the_value intro: map_idI)
 qed
 
 lemma the_value_Nil [simp]:
   "the_value [] = 0"
   by transfer (simp add: fun_eq_iff)
 
 lemma the_value_Cons [simp]:
   "the_value (x # xs) = update (fst x) (snd x) (the_value xs)"
   by transfer (simp add: fun_eq_iff)
 
 lemma items_zero [simp]:
   "items 0 = []"
   unfolding items_def by simp
 
 lemma items_one [simp]:
   "items 1 = [(0, 1)]"
   unfolding items_def by transfer simp
 
 lemma items_single [simp]:
   "items (single k v) = (if v = 0 then [] else [(k, v)])"
   unfolding items_def by simp
 
 lemma in_set_items_iff [simp]:
   "(k, v) \<in> set (items f) \<longleftrightarrow> k \<in> keys f \<and> lookup f k = v"
   unfolding items_def by transfer auto
 
 
 subsection \<open>Size estimation\<close>
 
 context
   fixes f :: "'a \<Rightarrow> nat"
   and g :: "'b :: zero \<Rightarrow> nat"
 begin
 
 definition poly_mapping_size :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> nat"
 where
   "poly_mapping_size m = g 0 + (\<Sum>k \<in> keys m. Suc (f k + g (lookup m k)))"
 
 lemma poly_mapping_size_0 [simp]:
   "poly_mapping_size 0 = g 0"
   by (simp add: poly_mapping_size_def)
 
 lemma poly_mapping_size_single [simp]:
   "poly_mapping_size (single k v) = (if v = 0 then g 0 else g 0 + f k + g v + 1)"
   unfolding poly_mapping_size_def by transfer simp
 
 lemma keys_less_poly_mapping_size:
   "k \<in> keys m \<Longrightarrow> f k + g (lookup m k) < poly_mapping_size m"
 unfolding poly_mapping_size_def
 proof transfer
   fix k :: 'a and m :: "'a \<Rightarrow> 'b" and f :: "'a \<Rightarrow> nat" and g
   let ?keys = "{k. m k \<noteq> 0}"
   assume *: "finite ?keys" "k \<in> ?keys"
   then have "f k + g (m k) = (\<Sum>k' \<in> ?keys. f k' + g (m k') when k' = k)"
     by (simp add: sum.delta when_def)
   also have "\<dots> < (\<Sum>k' \<in> ?keys. Suc (f k' + g (m k')))" using *
     by (intro sum_strict_mono) (auto simp add: when_def)
   also have "\<dots> \<le> g 0 + \<dots>" by simp
   finally have "f k + g (m k) < \<dots>" .
   then show "f k + g (m k) < g 0 + (\<Sum>k | m k \<noteq> 0. Suc (f k + g (m k)))"
     by simp
 qed
 
 lemma lookup_le_poly_mapping_size:
   "g (lookup m k) \<le> poly_mapping_size m"
 proof (cases "k \<in> keys m")
   case True
   with keys_less_poly_mapping_size [of k m]
   show ?thesis by simp
 next
   case False
   then show ?thesis
     by (simp add: Poly_Mapping.poly_mapping_size_def in_keys_iff)
 qed 
 
 lemma poly_mapping_size_estimation:
   "k \<in> keys m \<Longrightarrow> y \<le> f k + g (lookup m k) \<Longrightarrow> y < poly_mapping_size m"
   using keys_less_poly_mapping_size by (auto intro: le_less_trans)
 
 lemma poly_mapping_size_estimation2:
   assumes "v \<in> range m" and "y \<le> g v"
   shows "y < poly_mapping_size m"
 proof -
   from assms obtain k where *: "lookup m k = v" "v \<noteq> 0"
     by transfer blast
   from * have "k \<in> keys m"
     by (simp add: in_keys_iff)
   then show ?thesis
   proof (rule poly_mapping_size_estimation)
     from assms * have "y \<le> g (lookup m k)"
       by simp
     then show "y \<le> f k + g (lookup m k)"
       by simp
   qed
 qed
 
 end
 
 lemma poly_mapping_size_one [simp]:
   "poly_mapping_size f g 1 = g 0 + f 0 + g 1 + 1"
   unfolding poly_mapping_size_def by transfer simp
 
 lemma poly_mapping_size_cong [fundef_cong]:
   "m = m' \<Longrightarrow> g 0 = g' 0 \<Longrightarrow> (\<And>k. k \<in> keys m' \<Longrightarrow> f k = f' k)
     \<Longrightarrow> (\<And>v. v \<in> range m' \<Longrightarrow> g v = g' v)
     \<Longrightarrow> poly_mapping_size f g m = poly_mapping_size f' g' m'"
   by (auto simp add: poly_mapping_size_def intro!: sum.cong)
 
 instantiation poly_mapping :: (type, zero) size
 begin
 
 definition "size = poly_mapping_size (\<lambda>_. 0) (\<lambda>_. 0)"
 
 instance ..
 
 end
 
 
 subsection \<open>Further mapping operations and properties\<close>
 
 text \<open>It is like in algebra: there are many definitions, some are also used\<close>
 
 lift_definition mapp ::
   "('a \<Rightarrow> 'b :: zero \<Rightarrow> 'c :: zero) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'c)"
   is "\<lambda>f p k. (if k \<in> keys p then f k (lookup p k) else 0)"
   by simp
 
 lemma mapp_cong [fundef_cong]:
   "\<lbrakk> m = m'; \<And>k. k \<in> keys m' \<Longrightarrow> f k (lookup m' k) = f' k (lookup m' k) \<rbrakk>
   \<Longrightarrow> mapp f m = mapp f' m'"
   by transfer (auto simp add: fun_eq_iff)
 
 lemma lookup_mapp:
   "lookup (mapp f p) k = (f k (lookup p k) when k \<in> keys p)"
   by (simp add: mapp.rep_eq)
 
 lemma keys_mapp_subset: "keys (mapp f p) \<subseteq> keys p"
   by (meson in_keys_iff mapp.rep_eq subsetI)
 
 subsection\<open>Free Abelian Groups Over a Type\<close>
 
 abbreviation frag_of :: "'a \<Rightarrow> 'a \<Rightarrow>\<^sub>0 int"
   where "frag_of c \<equiv> Poly_Mapping.single c (1::int)"
 
 lemma lookup_frag_of [simp]:
    "Poly_Mapping.lookup(frag_of c) = (\<lambda>x. if x = c then 1 else 0)"
   by (force simp add: lookup_single_not_eq)
 
 lemma frag_of_nonzero [simp]: "frag_of a \<noteq> 0"
 proof -
   let ?f = "\<lambda>x. if x = a then 1 else (0::int)"
   have "?f \<noteq> (\<lambda>x. 0::int)"
     by (auto simp: fun_eq_iff)
   then have "Poly_Mapping.lookup (Abs_poly_mapping ?f) \<noteq> Poly_Mapping.lookup (Abs_poly_mapping (\<lambda>x. 0))"
     by fastforce
   then show ?thesis
     by (metis lookup_single_eq lookup_zero)
 qed
 
 definition frag_cmul :: "int \<Rightarrow> ('a \<Rightarrow>\<^sub>0 int) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 int)"
   where "frag_cmul c a = Abs_poly_mapping (\<lambda>x. c * Poly_Mapping.lookup a x)"
 
 lemma frag_cmul_zero [simp]: "frag_cmul 0 x = 0"
   by (simp add: frag_cmul_def)
 
 lemma frag_cmul_zero2 [simp]: "frag_cmul c 0 = 0"
   by (simp add: frag_cmul_def)
 
 lemma frag_cmul_one [simp]: "frag_cmul 1 x = x"
   by (auto simp: frag_cmul_def Poly_Mapping.poly_mapping.lookup_inverse)
 
 lemma frag_cmul_minus_one [simp]: "frag_cmul (-1) x = -x"
   by (simp add: frag_cmul_def uminus_poly_mapping_def poly_mapping_eqI)
 
 lemma frag_cmul_cmul [simp]: "frag_cmul c (frag_cmul d x) = frag_cmul (c*d) x"
   by (simp add: frag_cmul_def mult_ac)
 
 lemma lookup_frag_cmul [simp]: "poly_mapping.lookup (frag_cmul c x) i = c * poly_mapping.lookup x i"
   by (simp add: frag_cmul_def)
 
 lemma minus_frag_cmul [simp]: "- frag_cmul k x = frag_cmul (-k) x"
   by (simp add: poly_mapping_eqI)
 
 lemma keys_frag_of: "Poly_Mapping.keys(frag_of a) = {a}"
   by simp
 
 lemma finite_cmul_nonzero: "finite {x. c * Poly_Mapping.lookup a x \<noteq> (0::int)}"
   by simp
 
 lemma keys_cmul: "Poly_Mapping.keys(frag_cmul c a) \<subseteq> Poly_Mapping.keys a"
   using finite_cmul_nonzero [of c a]
   by (metis lookup_frag_cmul mult_zero_right not_in_keys_iff_lookup_eq_zero subsetI)
   
 
 lemma keys_cmul_iff [iff]: "i \<in> Poly_Mapping.keys (frag_cmul c x) \<longleftrightarrow> i \<in> Poly_Mapping.keys x \<and> c \<noteq> 0"
   apply (auto simp: )
   apply (meson subsetD keys_cmul)
   by (metis in_keys_iff lookup_frag_cmul mult_eq_0_iff)
 
 lemma keys_minus [simp]: "Poly_Mapping.keys(-a) = Poly_Mapping.keys a"
   by (metis (no_types, hide_lams) in_keys_iff lookup_uminus neg_equal_0_iff_equal subsetI subset_antisym)
 
 lemma keys_diff: 
   "Poly_Mapping.keys(a - b) \<subseteq> Poly_Mapping.keys a \<union> Poly_Mapping.keys b"
   by (auto simp add: in_keys_iff lookup_minus)
 
 lemma keys_eq_empty [simp]: "Poly_Mapping.keys c = {} \<longleftrightarrow> c = 0"
   by (metis in_keys_iff keys_zero lookup_zero poly_mapping_eqI)
 
 lemma frag_cmul_eq_0_iff [simp]: "frag_cmul k c = 0 \<longleftrightarrow> k=0 \<or> c=0"
   by auto (metis subsetI subset_antisym keys_cmul_iff keys_eq_empty)
 
 lemma frag_of_eq: "frag_of x = frag_of y \<longleftrightarrow> x = y"
   by (metis lookup_single_eq lookup_single_not_eq zero_neq_one)
 
 lemma frag_cmul_distrib: "frag_cmul (c+d) a = frag_cmul c a + frag_cmul d a"
   by (simp add: frag_cmul_def plus_poly_mapping_def int_distrib)
 
 lemma frag_cmul_distrib2: "frag_cmul c (a+b) = frag_cmul c a + frag_cmul c b"
 proof -
   have "finite {x. poly_mapping.lookup a x + poly_mapping.lookup b x \<noteq> 0}"
     using keys_add [of a b]
     by (metis (no_types, lifting) finite_keys finite_subset keys.rep_eq lookup_add mem_Collect_eq subsetI)
   then show ?thesis
     by (simp add: frag_cmul_def plus_poly_mapping_def int_distrib)
 qed
 
 lemma frag_cmul_diff_distrib: "frag_cmul (a - b) c = frag_cmul a c - frag_cmul b c"
   by (auto simp: left_diff_distrib lookup_minus poly_mapping_eqI)
 
 lemma frag_cmul_sum:
      "frag_cmul a (sum b I) = (\<Sum>i\<in>I. frag_cmul a (b i))"
 proof (induction rule: infinite_finite_induct)
   case (insert i I)
   then show ?case
     by (auto simp: algebra_simps frag_cmul_distrib2)
 qed auto
 
 lemma keys_sum: "Poly_Mapping.keys(sum b I) \<subseteq> (\<Union>i \<in>I. Poly_Mapping.keys(b i))"
 proof (induction I rule: infinite_finite_induct)
   case (insert i I)
   then show ?case
     using keys_add [of "b i" "sum b I"] by auto
 qed auto
 
 
 definition frag_extend :: "('b \<Rightarrow> 'a \<Rightarrow>\<^sub>0 int) \<Rightarrow> ('b \<Rightarrow>\<^sub>0 int) \<Rightarrow> 'a \<Rightarrow>\<^sub>0 int"
   where "frag_extend b x \<equiv> (\<Sum>i \<in> Poly_Mapping.keys x. frag_cmul (Poly_Mapping.lookup x i) (b i))"
 
 lemma frag_extend_0 [simp]: "frag_extend b 0 = 0"
   by (simp add: frag_extend_def)
 
 lemma frag_extend_of [simp]: "frag_extend f (frag_of a) = f a"
   by (simp add: frag_extend_def)
 
 lemma frag_extend_cmul:
    "frag_extend f (frag_cmul c x) = frag_cmul c (frag_extend f x)"
   by (auto simp: frag_extend_def frag_cmul_sum intro: sum.mono_neutral_cong_left)
 
 lemma frag_extend_minus:
    "frag_extend f (- x) = - (frag_extend f x)"
   using frag_extend_cmul [of f "-1"] by simp
 
 lemma frag_extend_add:
   "frag_extend f (a+b) = (frag_extend f a) + (frag_extend f b)"
 proof -
   have *: "(\<Sum>i\<in>Poly_Mapping.keys a. frag_cmul (poly_mapping.lookup a i) (f i)) 
          = (\<Sum>i\<in>Poly_Mapping.keys a \<union> Poly_Mapping.keys b. frag_cmul (poly_mapping.lookup a i) (f i))"
           "(\<Sum>i\<in>Poly_Mapping.keys b. frag_cmul (poly_mapping.lookup b i) (f i)) 
          = (\<Sum>i\<in>Poly_Mapping.keys a \<union> Poly_Mapping.keys b. frag_cmul (poly_mapping.lookup b i) (f i))"
     by (auto simp: in_keys_iff intro: sum.mono_neutral_cong_left)
   have "frag_extend f (a+b) = (\<Sum>i\<in>Poly_Mapping.keys (a + b).
        frag_cmul (poly_mapping.lookup a i) (f i) + frag_cmul (poly_mapping.lookup b i) (f i)) "
     by (auto simp: frag_extend_def Poly_Mapping.lookup_add frag_cmul_distrib)
   also have "... = (\<Sum>i \<in> Poly_Mapping.keys a \<union> Poly_Mapping.keys b. frag_cmul (poly_mapping.lookup a i) (f i) 
                          + frag_cmul (poly_mapping.lookup b i) (f i))"
     apply (rule sum.mono_neutral_cong_left)
     using keys_add [of a b]
      apply (auto simp add: in_keys_iff plus_poly_mapping.rep_eq frag_cmul_distrib [symmetric])
     done
   also have "... = (frag_extend f a) + (frag_extend f b)"
     by (auto simp: * sum.distrib frag_extend_def)
   finally show ?thesis .
 qed
 
 lemma frag_extend_diff:
    "frag_extend f (a-b) = (frag_extend f a) - (frag_extend f b)"
   by (metis (no_types, hide_lams) add_uminus_conv_diff frag_extend_add frag_extend_minus)
 
 lemma frag_extend_sum:
    "finite I \<Longrightarrow> frag_extend f (\<Sum>i\<in>I. g i) = sum (frag_extend f o g) I"
   by (induction I rule: finite_induct) (simp_all add: frag_extend_add)
 
 lemma frag_extend_eq:
    "(\<And>f. f \<in> Poly_Mapping.keys c \<Longrightarrow> g f = h f) \<Longrightarrow> frag_extend g c = frag_extend h c"
   by (simp add: frag_extend_def)
 
 lemma frag_extend_eq_0:
    "(\<And>x. x \<in> Poly_Mapping.keys c \<Longrightarrow> f x = 0) \<Longrightarrow> frag_extend f c = 0"
   by (simp add: frag_extend_def)
 
 lemma keys_frag_extend: "Poly_Mapping.keys(frag_extend f c) \<subseteq> (\<Union>x \<in> Poly_Mapping.keys c. Poly_Mapping.keys(f x))"
   unfolding frag_extend_def
-  by (smt SUP_mono' keys_cmul keys_sum order_trans)
+  using keys_sum by fastforce
 
 lemma frag_expansion: "a = frag_extend frag_of a"
 proof -
   have *: "finite I
         \<Longrightarrow> Poly_Mapping.lookup (\<Sum>i\<in>I. frag_cmul (Poly_Mapping.lookup a i) (frag_of i)) j =
             (if j \<in> I then Poly_Mapping.lookup a j else 0)" for I j
     by (induction I rule: finite_induct) (auto simp: lookup_single lookup_add)
   show ?thesis
     unfolding frag_extend_def
     by (rule poly_mapping_eqI) (fastforce simp add: in_keys_iff *)
 qed
 
 lemma frag_closure_minus_cmul:
   assumes "P 0" and P: "\<And>x y. \<lbrakk>P x; P y\<rbrakk> \<Longrightarrow> P(x - y)" "P c"
   shows "P(frag_cmul k c)"
 proof -
   have "P (frag_cmul (int n) c)" for n
     apply (induction n)
      apply (simp_all add: assms frag_cmul_distrib)
     by (metis add.left_neutral add_diff_cancel_right' add_uminus_conv_diff P)
   then show ?thesis
     by (metis (no_types, hide_lams) add_diff_eq assms(2) diff_add_cancel frag_cmul_distrib int_diff_cases)
 qed
 
 lemma frag_induction [consumes 1, case_names zero one diff]:
   assumes supp: "Poly_Mapping.keys c \<subseteq> S"
     and 0: "P 0" and sing: "\<And>x. x \<in> S \<Longrightarrow> P(frag_of x)"
     and diff: "\<And>a b. \<lbrakk>P a; P b\<rbrakk> \<Longrightarrow> P(a - b)"
   shows "P c"
 proof -
   have "P (\<Sum>i\<in>I. frag_cmul (poly_mapping.lookup c i) (frag_of i))"
     if "I \<subseteq> Poly_Mapping.keys c" for I
     using finite_subset [OF that finite_keys [of c]] that supp
   proof (induction I arbitrary: c rule: finite_induct)
     case empty
     then show ?case
       by (auto simp: 0)
   next
     case (insert i I c)
     have ab: "a+b = a - (0 - b)" for a b :: "'a \<Rightarrow>\<^sub>0 int"
       by simp
     have Pfrag: "P (frag_cmul (poly_mapping.lookup c i) (frag_of i))"
       by (metis "0" diff frag_closure_minus_cmul insert.prems insert_subset sing subset_iff)
     show ?case
       apply (simp add: insert.hyps)
       apply (subst ab)
       using insert apply (blast intro: assms Pfrag)
       done
   qed
   then show ?thesis
     by (subst frag_expansion) (auto simp add: frag_extend_def)
 qed
 
 lemma frag_extend_compose:
   "frag_extend f (frag_extend (frag_of o g) c) = frag_extend (f o g) c"
   using subset_UNIV
   by (induction c rule: frag_induction) (auto simp: frag_extend_diff)
 
 lemma frag_split:
   fixes c :: "'a \<Rightarrow>\<^sub>0 int"
   assumes "Poly_Mapping.keys c \<subseteq> S \<union> T"
   obtains d e where "Poly_Mapping.keys d \<subseteq> S" "Poly_Mapping.keys e \<subseteq> T" "d + e = c"
 proof 
   let ?d = "frag_extend (\<lambda>f. if f \<in> S then frag_of f else 0) c"
   let ?e = "frag_extend (\<lambda>f. if f \<in> S then 0 else frag_of f) c"
   show "Poly_Mapping.keys ?d \<subseteq> S" "Poly_Mapping.keys ?e \<subseteq> T"
     using assms by (auto intro!: order_trans [OF keys_frag_extend] split: if_split_asm)
   show "?d + ?e = c"
     using assms
   proof (induction c rule: frag_induction)
     case (diff a b)
     then show ?case
       by (metis (no_types, lifting) frag_extend_diff add_diff_eq diff_add_eq diff_add_eq_diff_diff_swap)
   qed auto
 qed
 
 hide_const (open) lookup single update keys range map map_key degree nth the_value items foldr mapp
 
 end
\ No newline at end of file
diff --git a/src/HOL/Library/Ramsey.thy b/src/HOL/Library/Ramsey.thy
--- a/src/HOL/Library/Ramsey.thy
+++ b/src/HOL/Library/Ramsey.thy
@@ -1,999 +1,999 @@
 (*  Title:      HOL/Library/Ramsey.thy
     Author:     Tom Ridge. Full finite version by L C Paulson.
 *)
 
 section \<open>Ramsey's Theorem\<close>
 
 theory Ramsey
   imports Infinite_Set FuncSet
 begin
 
 subsection \<open>Preliminary definitions\<close>
 
 subsubsection \<open>The $n$-element subsets of a set $A$\<close>
 
 definition nsets :: "['a set, nat] \<Rightarrow> 'a set set" ("([_]\<^bsup>_\<^esup>)" [0,999] 999)
   where "nsets A n \<equiv> {N. N \<subseteq> A \<and> finite N \<and> card N = n}"
 
 lemma nsets_mono: "A \<subseteq> B \<Longrightarrow> nsets A n \<subseteq> nsets B n"
   by (auto simp: nsets_def)
 
 lemma nsets_Pi_contra: "A' \<subseteq> A \<Longrightarrow> Pi ([A]\<^bsup>n\<^esup>) B \<subseteq> Pi ([A']\<^bsup>n\<^esup>) B"
   by (auto simp: nsets_def)
 
 lemma nsets_2_eq: "nsets A 2 = (\<Union>x\<in>A. \<Union>y\<in>A - {x}. {{x, y}})"
   by (auto simp: nsets_def card_2_iff)
 
 lemma nsets_doubleton_2_eq [simp]: "[{x, y}]\<^bsup>2\<^esup> = (if x=y then {} else {{x, y}})"
   by (auto simp: nsets_2_eq)
 
 lemma doubleton_in_nsets_2 [simp]: "{x,y} \<in> [A]\<^bsup>2\<^esup> \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> x \<noteq> y"
   by (auto simp: nsets_2_eq Set.doubleton_eq_iff)
 
 lemma nsets_3_eq: "nsets A 3 = (\<Union>x\<in>A. \<Union>y\<in>A - {x}. \<Union>z\<in>A - {x,y}. {{x,y,z}})"
   by (simp add: eval_nat_numeral nsets_def card_Suc_eq) blast
 
 lemma nsets_4_eq: "[A]\<^bsup>4\<^esup> = (\<Union>u\<in>A. \<Union>x\<in>A - {u}. \<Union>y\<in>A - {u,x}. \<Union>z\<in>A - {u,x,y}. {{u,x,y,z}})"
      (is "_ = ?rhs")
 proof
   show "[A]\<^bsup>4\<^esup> \<subseteq> ?rhs"
     by (clarsimp simp add: nsets_def eval_nat_numeral card_Suc_eq) blast
   show "?rhs \<subseteq> [A]\<^bsup>4\<^esup>"
     apply (clarsimp simp add: nsets_def eval_nat_numeral card_Suc_eq)
     by (metis insert_iff singletonD)
 qed
 
 lemma nsets_disjoint_2:
   "X \<inter> Y = {} \<Longrightarrow> [X \<union> Y]\<^bsup>2\<^esup> = [X]\<^bsup>2\<^esup> \<union> [Y]\<^bsup>2\<^esup> \<union> (\<Union>x\<in>X. \<Union>y\<in>Y. {{x,y}})"
   by (fastforce simp: nsets_2_eq Set.doubleton_eq_iff)
 
 lemma ordered_nsets_2_eq:
   fixes A :: "'a::linorder set"
   shows "nsets A 2 = {{x,y} | x y. x \<in> A \<and> y \<in> A \<and> x<y}"
      (is "_ = ?rhs")
 proof
   show "nsets A 2 \<subseteq> ?rhs"
     unfolding numeral_nat
     apply (clarsimp simp add: nsets_def card_Suc_eq Set.doubleton_eq_iff not_less)
     by (metis antisym)
   show "?rhs \<subseteq> nsets A 2"
     unfolding numeral_nat by (auto simp: nsets_def card_Suc_eq)
 qed
 
 lemma ordered_nsets_3_eq:
   fixes A :: "'a::linorder set"
   shows "nsets A 3 = {{x,y,z} | x y z. x \<in> A \<and> y \<in> A \<and> z \<in> A \<and> x<y \<and> y<z}"
      (is "_ = ?rhs")
 proof
   show "nsets A 3 \<subseteq> ?rhs"
     apply (clarsimp simp add: nsets_def card_Suc_eq eval_nat_numeral)
     by (metis insert_commute linorder_cases)
   show "?rhs \<subseteq> nsets A 3"
     apply (clarsimp simp add: nsets_def card_Suc_eq eval_nat_numeral)
   by (metis empty_iff insert_iff not_less_iff_gr_or_eq)
 qed
 
 lemma ordered_nsets_4_eq:
   fixes A :: "'a::linorder set"
   shows "[A]\<^bsup>4\<^esup> = {U. \<exists>u x y z. U = {u,x,y,z} \<and> u \<in> A \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A \<and> u < x \<and> x < y \<and> y < z}"
     (is "_ = Collect ?RHS")
 proof -
   { fix U
     assume "U \<in> [A]\<^bsup>4\<^esup>"
     then obtain l where "strict_sorted l" "List.set l = U" "length l = 4" "U \<subseteq> A"
       by (simp add: nsets_def) (metis finite_set_strict_sorted)
     then have "?RHS U"
       unfolding numeral_nat length_Suc_conv by auto blast }
   moreover
   have "Collect ?RHS \<subseteq> [A]\<^bsup>4\<^esup>"
     apply (clarsimp simp add: nsets_def eval_nat_numeral)
     apply (subst card_insert_disjoint, auto)+
     done
   ultimately show ?thesis
     by auto
 qed
 
 lemma ordered_nsets_5_eq:
   fixes A :: "'a::linorder set"
   shows "[A]\<^bsup>5\<^esup> = {U. \<exists>u v x y z. U = {u,v,x,y,z} \<and> u \<in> A \<and> v \<in> A \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A \<and> u < v \<and> v < x \<and> x < y \<and> y < z}"
     (is "_ = Collect ?RHS")
 proof -
   { fix U
   assume "U \<in> [A]\<^bsup>5\<^esup>"
   then obtain l where "strict_sorted l" "List.set l = U" "length l = 5" "U \<subseteq> A"
     apply (simp add: nsets_def)
     by (metis finite_set_strict_sorted)
   then have "?RHS U"
     unfolding numeral_nat length_Suc_conv by auto blast }
   moreover
   have "Collect ?RHS \<subseteq> [A]\<^bsup>5\<^esup>"
     apply (clarsimp simp add: nsets_def eval_nat_numeral)
     apply (subst card_insert_disjoint, auto)+
     done
   ultimately show ?thesis
     by auto
 qed
 
 lemma binomial_eq_nsets: "n choose k = card (nsets {0..<n} k)"
   apply (simp add: binomial_def nsets_def)
   by (meson subset_eq_atLeast0_lessThan_finite)
 
 lemma nsets_eq_empty_iff: "nsets A r = {} \<longleftrightarrow> finite A \<and> card A < r"
   unfolding nsets_def
 proof (intro iffI conjI)
   assume that: "{N. N \<subseteq> A \<and> finite N \<and> card N = r} = {}"
   show "finite A"
     using infinite_arbitrarily_large that by auto
   then have "\<not> r \<le> card A"
     using that by (simp add: set_eq_iff) (metis obtain_subset_with_card_n)
   then show "card A < r"
     using not_less by blast
 next
   show "{N. N \<subseteq> A \<and> finite N \<and> card N = r} = {}"
     if "finite A \<and> card A < r"
     using that card_mono leD by auto
 qed
 
 lemma nsets_eq_empty: "\<lbrakk>finite A; card A < r\<rbrakk> \<Longrightarrow> nsets A r = {}"
   by (simp add: nsets_eq_empty_iff)
 
 lemma nsets_empty_iff: "nsets {} r = (if r=0 then {{}} else {})"
   by (auto simp: nsets_def)
 
 lemma nsets_singleton_iff: "nsets {a} r = (if r=0 then {{}} else if r=1 then {{a}} else {})"
   by (auto simp: nsets_def card_gt_0_iff subset_singleton_iff)
 
 lemma nsets_self [simp]: "nsets {..<m} m = {{..<m}}"
   unfolding nsets_def
   apply auto
   by (metis add.left_neutral lessThan_atLeast0 lessThan_iff subset_card_intvl_is_intvl)
 
 lemma nsets_zero [simp]: "nsets A 0 = {{}}"
   by (auto simp: nsets_def)
 
 lemma nsets_one: "nsets A (Suc 0) = (\<lambda>x. {x}) ` A"
   using card_eq_SucD by (force simp: nsets_def)
 
 lemma inj_on_nsets:
   assumes "inj_on f A"
   shows "inj_on (\<lambda>X. f ` X) ([A]\<^bsup>n\<^esup>)"
   using assms unfolding nsets_def
   by (metis (no_types, lifting) inj_on_inverseI inv_into_image_cancel mem_Collect_eq)
 
 lemma bij_betw_nsets:
   assumes "bij_betw f A B"
   shows "bij_betw (\<lambda>X. f ` X) ([A]\<^bsup>n\<^esup>) ([B]\<^bsup>n\<^esup>)"
 proof -
   have "(`) f ` [A]\<^bsup>n\<^esup> = [f ` A]\<^bsup>n\<^esup>"
     using assms
     apply (auto simp: nsets_def bij_betw_def image_iff card_image inj_on_subset)
     by (metis card_image inj_on_finite order_refl subset_image_inj)
   with assms show ?thesis
     by (auto simp: bij_betw_def inj_on_nsets)
 qed
 
 lemma nset_image_obtains:
   assumes "X \<in> [f`A]\<^bsup>k\<^esup>" "inj_on f A"
   obtains Y where "Y \<in> [A]\<^bsup>k\<^esup>" "X = f ` Y"
   using assms
   apply (clarsimp simp add: nsets_def subset_image_iff)
   by (metis card_image finite_imageD inj_on_subset)
 
 lemma nsets_image_funcset:
   assumes "g \<in> S \<rightarrow> T" and "inj_on g S"
   shows "(\<lambda>X. g ` X) \<in> [S]\<^bsup>k\<^esup> \<rightarrow> [T]\<^bsup>k\<^esup>"
     using assms
     by (fastforce simp add: nsets_def card_image inj_on_subset subset_iff simp flip: image_subset_iff_funcset)
 
 lemma nsets_compose_image_funcset:
   assumes f: "f \<in> [T]\<^bsup>k\<^esup> \<rightarrow> D" and "g \<in> S \<rightarrow> T" and "inj_on g S"
   shows "f \<circ> (\<lambda>X. g ` X) \<in> [S]\<^bsup>k\<^esup> \<rightarrow> D"
 proof -
   have "(\<lambda>X. g ` X) \<in> [S]\<^bsup>k\<^esup> \<rightarrow> [T]\<^bsup>k\<^esup>"
     using assms by (simp add: nsets_image_funcset)
   then show ?thesis
     using f by fastforce
 qed
 
 subsubsection \<open>Partition predicates\<close>
 
 definition partn :: "'a set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'b set \<Rightarrow> bool"
   where "partn \<beta> \<alpha> \<gamma> \<delta> \<equiv> \<forall>f \<in> nsets \<beta> \<gamma>  \<rightarrow>  \<delta>. \<exists>H \<in> nsets \<beta> \<alpha>. \<exists>\<xi>\<in>\<delta>. f ` (nsets H \<gamma>) \<subseteq> {\<xi>}"
 
 definition partn_lst :: "'a set \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
   where "partn_lst \<beta> \<alpha> \<gamma> \<equiv> \<forall>f \<in> nsets \<beta> \<gamma>  \<rightarrow>  {..<length \<alpha>}.
               \<exists>i < length \<alpha>. \<exists>H \<in> nsets \<beta> (\<alpha>!i). f ` (nsets H \<gamma>) \<subseteq> {i}"
 
 lemma partn_lst_greater_resource:
   fixes M::nat
   assumes M: "partn_lst {..<M} \<alpha> \<gamma>" and "M \<le> N"
   shows "partn_lst {..<N} \<alpha> \<gamma>"
 proof (clarsimp simp: partn_lst_def)
   fix f
   assume "f \<in> nsets {..<N} \<gamma> \<rightarrow> {..<length \<alpha>}"
   then have "f \<in> nsets {..<M} \<gamma> \<rightarrow> {..<length \<alpha>}"
     by (meson Pi_anti_mono \<open>M \<le> N\<close> lessThan_subset_iff nsets_mono subsetD)
   then obtain i H where i: "i < length \<alpha>" and H: "H \<in> nsets {..<M} (\<alpha> ! i)" and subi: "f ` nsets H \<gamma> \<subseteq> {i}"
     using M partn_lst_def by blast
   have "H \<in> nsets {..<N} (\<alpha> ! i)"
     using \<open>M \<le> N\<close> H by (auto simp: nsets_def subset_iff)
   then show "\<exists>i<length \<alpha>. \<exists>H\<in>nsets {..<N} (\<alpha> ! i). f ` nsets H \<gamma> \<subseteq> {i}"
     using i subi by blast
 qed
 
 lemma partn_lst_fewer_colours:
   assumes major: "partn_lst \<beta> (n#\<alpha>) \<gamma>" and "n \<ge> \<gamma>"
   shows "partn_lst \<beta> \<alpha> \<gamma>"
 proof (clarsimp simp: partn_lst_def)
   fix f :: "'a set \<Rightarrow> nat"
   assume f: "f \<in> [\<beta>]\<^bsup>\<gamma>\<^esup> \<rightarrow> {..<length \<alpha>}"
   then obtain i H where i: "i < Suc (length \<alpha>)"
       and H: "H \<in> [\<beta>]\<^bsup>((n # \<alpha>) ! i)\<^esup>"
       and hom: "\<forall>x\<in>[H]\<^bsup>\<gamma>\<^esup>. Suc (f x) = i"
     using \<open>n \<ge> \<gamma>\<close> major [unfolded partn_lst_def, rule_format, of "Suc o f"]
     by (fastforce simp: image_subset_iff nsets_eq_empty_iff)
   show "\<exists>i<length \<alpha>. \<exists>H\<in>nsets \<beta> (\<alpha> ! i). f ` [H]\<^bsup>\<gamma>\<^esup> \<subseteq> {i}"
   proof (cases i)
     case 0
     then have "[H]\<^bsup>\<gamma>\<^esup> = {}"
       using hom by blast
     then show ?thesis
       using 0 H \<open>n \<ge> \<gamma>\<close>
       by (simp add: nsets_eq_empty_iff) (simp add: nsets_def)
   next
     case (Suc i')
     then show ?thesis
       using i H hom by auto
   qed
 qed
 
 lemma partn_lst_eq_partn: "partn_lst {..<n} [m,m] 2 = partn {..<n} m 2 {..<2::nat}"
   apply (simp add: partn_lst_def partn_def numeral_2_eq_2)
   by (metis less_2_cases numeral_2_eq_2 lessThan_iff nth_Cons_0 nth_Cons_Suc)
 
 
 subsection \<open>Finite versions of Ramsey's theorem\<close>
 
 text \<open>
   To distinguish the finite and infinite ones, lower and upper case
   names are used.
 \<close>
 
 subsubsection \<open>Trivial cases\<close>
 
 text \<open>Vacuous, since we are dealing with 0-sets!\<close>
 lemma ramsey0: "\<exists>N::nat. partn_lst {..<N} [q1,q2] 0"
   by (force simp: partn_lst_def ex_in_conv less_Suc_eq nsets_eq_empty_iff)
 
 text \<open>Just the pigeon hole principle, since we are dealing with 1-sets\<close>
 lemma ramsey1: "\<exists>N::nat. partn_lst {..<N} [q0,q1] 1"
 proof -
   have "\<exists>i<Suc (Suc 0). \<exists>H\<in>nsets {..<Suc (q0 + q1)} ([q0, q1] ! i). f ` nsets H (Suc 0) \<subseteq> {i}"
     if "f \<in> nsets {..<Suc (q0 + q1)} (Suc 0) \<rightarrow> {..<Suc (Suc 0)}" for f
   proof -
     define A where "A \<equiv> \<lambda>i. {q. q \<le> q0+q1 \<and> f {q} = i}"
     have "A 0 \<union> A 1 = {..q0 + q1}"
       using that by (auto simp: A_def PiE_iff nsets_one lessThan_Suc_atMost le_Suc_eq)
     moreover have "A 0 \<inter> A 1 = {}"
       by (auto simp: A_def)
     ultimately have "q0 + q1 \<le> card (A 0) + card (A 1)"
       by (metis card_Un_le card_atMost eq_imp_le le_SucI le_trans)
     then consider "card (A 0) \<ge> q0" | "card (A 1) \<ge> q1"
       by linarith
     then obtain i where "i < Suc (Suc 0)" "card (A i) \<ge> [q0, q1] ! i"
       by (metis One_nat_def lessI nth_Cons_0 nth_Cons_Suc zero_less_Suc)
     then obtain B where "B \<subseteq> A i" "card B = [q0, q1] ! i" "finite B"
       by (meson obtain_subset_with_card_n)
     then have "B \<in> nsets {..<Suc (q0 + q1)} ([q0, q1] ! i) \<and> f ` nsets B (Suc 0) \<subseteq> {i}"
       by (auto simp: A_def nsets_def card_1_singleton_iff)
     then show ?thesis
       using \<open>i < Suc (Suc 0)\<close> by auto
   qed
   then show ?thesis
     by (clarsimp simp: partn_lst_def) blast
 qed
 
 
 subsubsection \<open>Ramsey's theorem with two colours and arbitrary exponents (hypergraph version)\<close>
 
 proposition ramsey2_full: "\<exists>N::nat. partn_lst {..<N} [q1,q2] r"
 proof (induction r arbitrary: q1 q2)
   case 0
   then show ?case
     by (simp add: ramsey0)
 next
   case (Suc r)
   note outer = this
   show ?case
   proof (cases "r = 0")
     case True
     then show ?thesis
       using ramsey1 by auto
   next
     case False
     then have "r > 0"
       by simp
     show ?thesis
       using Suc.prems
     proof (induct k \<equiv> "q1 + q2" arbitrary: q1 q2)
       case 0
       show ?case
       proof
         show "partn_lst {..<1::nat} [q1, q2] (Suc r)"
           using nsets_empty_iff subset_insert 0
           by (fastforce simp: partn_lst_def funcset_to_empty_iff nsets_eq_empty image_subset_iff)
       qed
     next
       case (Suc k)
       consider "q1 = 0 \<or> q2 = 0" | "q1 \<noteq> 0" "q2 \<noteq> 0" by auto
       then show ?case
       proof cases
         case 1
         then have "partn_lst {..< Suc 0} [q1, q2] (Suc r)"
           unfolding partn_lst_def using \<open>r > 0\<close>
           by (fastforce simp add: nsets_empty_iff nsets_singleton_iff lessThan_Suc)
         then show ?thesis by blast
       next
         case 2
         with Suc have "k = (q1 - 1) + q2" "k = q1 + (q2 - 1)" by auto
         then obtain p1 p2::nat where  p1: "partn_lst {..<p1} [q1-1,q2] (Suc r)" and p2: "partn_lst {..<p2} [q1,q2-1] (Suc r)"
           using Suc.hyps by blast
         then obtain p::nat where p: "partn_lst {..<p} [p1,p2] r"
           using outer Suc.prems by auto
         show ?thesis
         proof (intro exI conjI)
           have "\<exists>i<Suc (Suc 0). \<exists>H\<in>nsets {..p} ([q1,q2] ! i). f ` nsets H (Suc r) \<subseteq> {i}"
             if f: "f \<in> nsets {..p} (Suc r) \<rightarrow> {..<Suc (Suc 0)}" for f
           proof -
             define g where "g \<equiv> \<lambda>R. f (insert p R)"
             have "f (insert p i) \<in> {..<Suc (Suc 0)}" if "i \<in> nsets {..<p} r" for i
               using that card_insert_if by (fastforce simp: nsets_def intro!: Pi_mem [OF f])
             then have g: "g \<in> nsets {..<p} r \<rightarrow> {..<Suc (Suc 0)}"
               by (force simp: g_def PiE_iff)
             then obtain i U where i: "i < Suc (Suc 0)" and gi: "g ` nsets U r \<subseteq> {i}"
               and U: "U \<in> nsets {..<p} ([p1, p2] ! i)"
               using p by (auto simp: partn_lst_def)
             then have Usub: "U \<subseteq> {..<p}"
               by (auto simp: nsets_def)
             consider (izero) "i = 0" | (ione) "i = Suc 0"
               using i by linarith
             then show ?thesis
             proof cases
               case izero
               then have "U \<in> nsets {..<p} p1"
                 using U by simp
               then obtain u where u: "bij_betw u {..<p1} U"
                 using ex_bij_betw_nat_finite lessThan_atLeast0 by (fastforce simp add: nsets_def)
               have u_nsets: "u ` X \<in> nsets {..p} n" if "X \<in> nsets {..<p1} n" for X n
               proof -
                 have "inj_on u X"
                   using u that bij_betw_imp_inj_on inj_on_subset by (force simp: nsets_def)
                 then show ?thesis
                   using Usub u that bij_betwE
                   by (fastforce simp add: nsets_def card_image)
               qed
               define h where "h \<equiv> \<lambda>R. f (u ` R)"
               have "h \<in> nsets {..<p1} (Suc r) \<rightarrow> {..<Suc (Suc 0)}"
                 unfolding h_def using f u_nsets by auto
               then obtain j V where j: "j <Suc (Suc 0)" and hj: "h ` nsets V (Suc r) \<subseteq> {j}"
                 and V: "V \<in> nsets {..<p1} ([q1 - Suc 0, q2] ! j)"
                 using p1 by (auto simp: partn_lst_def)
               then have Vsub: "V \<subseteq> {..<p1}"
                 by (auto simp: nsets_def)
               have invinv_eq: "u ` inv_into {..<p1} u ` X = X" if "X \<subseteq> u ` {..<p1}" for X
                 by (simp add: image_inv_into_cancel that)
               let ?W = "insert p (u ` V)"
               consider (jzero) "j = 0" | (jone) "j = Suc 0"
                 using j by linarith
               then show ?thesis
               proof cases
                 case jzero
                 then have "V \<in> nsets {..<p1} (q1 - Suc 0)"
                   using V by simp
                 then have "u ` V \<in> nsets {..<p} (q1 - Suc 0)"
                   using u_nsets [of _ "q1 - Suc 0"] nsets_mono [OF Vsub] Usub u
                   unfolding bij_betw_def nsets_def
                   by (fastforce elim!: subsetD)
                 then have inq1: "?W \<in> nsets {..p} q1"
                   unfolding nsets_def using \<open>q1 \<noteq> 0\<close> card_insert_if by fastforce
                 have invu_nsets: "inv_into {..<p1} u ` X \<in> nsets V r"
                   if "X \<in> nsets (u ` V) r" for X r
                 proof -
                   have "X \<subseteq> u ` V \<and> finite X \<and> card X = r"
                     using nsets_def that by auto
                   then have [simp]: "card (inv_into {..<p1} u ` X) = card X"
                     by (meson Vsub bij_betw_def bij_betw_inv_into card_image image_mono inj_on_subset u)
                   show ?thesis
                     using that u Vsub by (fastforce simp: nsets_def bij_betw_def)
                 qed
                 have "f X = i" if X: "X \<in> nsets ?W (Suc r)" for X
                 proof (cases "p \<in> X")
                   case True
                   then have Xp: "X - {p} \<in> nsets (u ` V) r"
                     using X by (auto simp: nsets_def)
                   moreover have "u ` V \<subseteq> U"
                     using Vsub bij_betwE u by blast
                   ultimately have "X - {p} \<in> nsets U r"
                     by (meson in_mono nsets_mono)
                   then have "g (X - {p}) = i"
                     using gi by blast
                   have "f X = i"
                     using gi True \<open>X - {p} \<in> nsets U r\<close> insert_Diff
                     by (fastforce simp add: g_def image_subset_iff)
                   then show ?thesis
                     by (simp add: \<open>f X = i\<close> \<open>g (X - {p}) = i\<close>)
                 next
                   case False
                   then have Xim: "X \<in> nsets (u ` V) (Suc r)"
                     using X by (auto simp: nsets_def subset_insert)
                   then have "u ` inv_into {..<p1} u ` X = X"
                     using Vsub bij_betw_imp_inj_on u
                     by (fastforce simp: nsets_def image_mono invinv_eq subset_trans)
                   then show ?thesis
                     using izero jzero hj Xim invu_nsets unfolding h_def
                     by (fastforce simp add: image_subset_iff)
                 qed
                 moreover have "insert p (u ` V) \<in> nsets {..p} q1"
                   by (simp add: izero inq1)
                 ultimately show ?thesis
                   by (metis izero image_subsetI insertI1 nth_Cons_0 zero_less_Suc)
               next
                 case jone
                 then have "u ` V \<in> nsets {..p} q2"
                   using V u_nsets by auto
                 moreover have "f ` nsets (u ` V) (Suc r) \<subseteq> {j}"
                   using hj
                   by (force simp add: h_def image_subset_iff nsets_def subset_image_inj card_image dest: finite_imageD)
                 ultimately show ?thesis
                   using jone not_less_eq by fastforce
               qed
             next
               case ione
               then have "U \<in> nsets {..<p} p2"
                 using U by simp
               then obtain u where u: "bij_betw u {..<p2} U"
                 using ex_bij_betw_nat_finite lessThan_atLeast0 by (fastforce simp add: nsets_def)
               have u_nsets: "u ` X \<in> nsets {..p} n" if "X \<in> nsets {..<p2} n" for X n
               proof -
                 have "inj_on u X"
                   using u that bij_betw_imp_inj_on inj_on_subset by (force simp: nsets_def)
                 then show ?thesis
                   using Usub u that bij_betwE
                   by (fastforce simp add: nsets_def card_image)
               qed
               define h where "h \<equiv> \<lambda>R. f (u ` R)"
               have "h \<in> nsets {..<p2} (Suc r) \<rightarrow> {..<Suc (Suc 0)}"
                 unfolding h_def using f u_nsets by auto
               then obtain j V where j: "j <Suc (Suc 0)" and hj: "h ` nsets V (Suc r) \<subseteq> {j}"
                 and V: "V \<in> nsets {..<p2} ([q1, q2 - Suc 0] ! j)"
                 using p2 by (auto simp: partn_lst_def)
               then have Vsub: "V \<subseteq> {..<p2}"
                 by (auto simp: nsets_def)
               have invinv_eq: "u ` inv_into {..<p2} u ` X = X" if "X \<subseteq> u ` {..<p2}" for X
                 by (simp add: image_inv_into_cancel that)
               let ?W = "insert p (u ` V)"
               consider (jzero) "j = 0" | (jone) "j = Suc 0"
                 using j by linarith
               then show ?thesis
               proof cases
                 case jone
                 then have "V \<in> nsets {..<p2} (q2 - Suc 0)"
                   using V by simp
                 then have "u ` V \<in> nsets {..<p} (q2 - Suc 0)"
                   using u_nsets [of _ "q2 - Suc 0"] nsets_mono [OF Vsub] Usub u
                   unfolding bij_betw_def nsets_def
                   by (fastforce elim!: subsetD)
                 then have inq1: "?W \<in> nsets {..p} q2"
                   unfolding nsets_def using \<open>q2 \<noteq> 0\<close> card_insert_if by fastforce
                 have invu_nsets: "inv_into {..<p2} u ` X \<in> nsets V r"
                   if "X \<in> nsets (u ` V) r" for X r
                 proof -
                   have "X \<subseteq> u ` V \<and> finite X \<and> card X = r"
                     using nsets_def that by auto
                   then have [simp]: "card (inv_into {..<p2} u ` X) = card X"
                     by (meson Vsub bij_betw_def bij_betw_inv_into card_image image_mono inj_on_subset u)
                   show ?thesis
                     using that u Vsub by (fastforce simp: nsets_def bij_betw_def)
                 qed
                 have "f X = i" if X: "X \<in> nsets ?W (Suc r)" for X
                 proof (cases "p \<in> X")
                   case True
                   then have Xp: "X - {p} \<in> nsets (u ` V) r"
                     using X by (auto simp: nsets_def)
                   moreover have "u ` V \<subseteq> U"
                     using Vsub bij_betwE u by blast
                   ultimately have "X - {p} \<in> nsets U r"
                     by (meson in_mono nsets_mono)
                   then have "g (X - {p}) = i"
                     using gi by blast
                   have "f X = i"
                     using gi True \<open>X - {p} \<in> nsets U r\<close> insert_Diff
                     by (fastforce simp add: g_def image_subset_iff)
                   then show ?thesis
                     by (simp add: \<open>f X = i\<close> \<open>g (X - {p}) = i\<close>)
                 next
                   case False
                   then have Xim: "X \<in> nsets (u ` V) (Suc r)"
                     using X by (auto simp: nsets_def subset_insert)
                   then have "u ` inv_into {..<p2} u ` X = X"
                     using Vsub bij_betw_imp_inj_on u
                     by (fastforce simp: nsets_def image_mono invinv_eq subset_trans)
                   then show ?thesis
                     using ione jone hj Xim invu_nsets unfolding h_def
                     by (fastforce simp add: image_subset_iff)
                 qed
                 moreover have "insert p (u ` V) \<in> nsets {..p} q2"
                   by (simp add: ione inq1)
                 ultimately show ?thesis
                   by (metis ione image_subsetI insertI1 lessI nth_Cons_0 nth_Cons_Suc)
               next
                 case jzero
                 then have "u ` V \<in> nsets {..p} q1"
                   using V u_nsets by auto
                 moreover have "f ` nsets (u ` V) (Suc r) \<subseteq> {j}"
                   using hj
                   apply (clarsimp simp add: h_def image_subset_iff nsets_def)
                   by (metis Zero_not_Suc card_eq_0_iff card_image subset_image_inj)
                 ultimately show ?thesis
                   using jzero not_less_eq by fastforce
               qed
             qed
           qed
           then show "partn_lst {..<Suc p} [q1,q2] (Suc r)"
             using lessThan_Suc lessThan_Suc_atMost by (auto simp: partn_lst_def insert_commute)
         qed
       qed
     qed
   qed
 qed
 
 subsubsection \<open>Full Ramsey's theorem with multiple colours and arbitrary exponents\<close>
 
 theorem ramsey_full: "\<exists>N::nat. partn_lst {..<N} qs r"
 proof (induction k \<equiv> "length qs" arbitrary: qs)
   case 0
   then show ?case
     by (rule_tac x=" r" in exI) (simp add: partn_lst_def)
 next
   case (Suc k)
   note IH = this
   show ?case
   proof (cases k)
     case 0
     with Suc obtain q where "qs = [q]"
       by (metis length_0_conv length_Suc_conv)
     then show ?thesis
       by (rule_tac x=q in exI) (auto simp: partn_lst_def funcset_to_empty_iff)
   next
     case (Suc k')
     then obtain q1 q2 l where qs: "qs = q1#q2#l"
       by (metis Suc.hyps(2) length_Suc_conv)
     then obtain q::nat where q: "partn_lst {..<q} [q1,q2] r"
       using ramsey2_full by blast
     then obtain p::nat where p: "partn_lst {..<p} (q#l) r"
       using IH \<open>qs = q1 # q2 # l\<close> by fastforce
     have keq: "Suc (length l) = k"
       using IH qs by auto
     show ?thesis
     proof (intro exI conjI)
       show "partn_lst {..<p} qs r"
       proof (auto simp: partn_lst_def)
         fix f
         assume f: "f \<in> nsets {..<p} r \<rightarrow> {..<length qs}"
         define g where "g \<equiv> \<lambda>X. if f X < Suc (Suc 0) then 0 else f X - Suc 0"
         have "g \<in> nsets {..<p} r \<rightarrow> {..<k}"
           unfolding g_def using f Suc IH
           by (auto simp: Pi_def not_less)
         then obtain i U where i: "i < k" and gi: "g ` nsets U r \<subseteq> {i}"
                 and U: "U \<in> nsets {..<p} ((q#l) ! i)"
           using p keq by (auto simp: partn_lst_def)
         show "\<exists>i<length qs. \<exists>H\<in>nsets {..<p} (qs ! i). f ` nsets H r \<subseteq> {i}"
         proof (cases "i = 0")
           case True
           then have "U \<in> nsets {..<p} q" and f01: "f ` nsets U r \<subseteq> {0, Suc 0}"
             using U gi unfolding g_def by (auto simp: image_subset_iff)
           then obtain u where u: "bij_betw u {..<q} U"
             using ex_bij_betw_nat_finite lessThan_atLeast0 by (fastforce simp add: nsets_def)
           then have Usub: "U \<subseteq> {..<p}"
-            by (smt \<open>U \<in> nsets {..<p} q\<close> mem_Collect_eq nsets_def)
+            by (smt (verit) U mem_Collect_eq nsets_def)
           have u_nsets: "u ` X \<in> nsets {..<p} n" if "X \<in> nsets {..<q} n" for X n
           proof -
             have "inj_on u X"
               using u that bij_betw_imp_inj_on inj_on_subset
               by (force simp: nsets_def)
             then show ?thesis
               using Usub u that bij_betwE
               by (fastforce simp add: nsets_def card_image)
           qed
           define h where "h \<equiv> \<lambda>X. f (u ` X)"
           have "f (u ` X) < Suc (Suc 0)" if "X \<in> nsets {..<q} r" for X
           proof -
             have "u ` X \<in> nsets U r"
               using u u_nsets that by (auto simp: nsets_def bij_betwE subset_eq)
             then show ?thesis
               using f01 by auto
           qed
           then have "h \<in> nsets {..<q} r \<rightarrow> {..<Suc (Suc 0)}"
             unfolding h_def by blast
           then obtain j V where j: "j < Suc (Suc 0)" and hj: "h ` nsets V r \<subseteq> {j}"
             and V: "V \<in> nsets {..<q} ([q1,q2] ! j)"
             using q by (auto simp: partn_lst_def)
           show ?thesis
           proof (intro exI conjI bexI)
             show "j < length qs"
               using Suc Suc.hyps(2) j by linarith
             have "nsets (u ` V) r \<subseteq> (\<lambda>x. (u ` x)) ` nsets V r"
               apply (clarsimp simp add: nsets_def image_iff)
               by (metis card_eq_0_iff card_image image_is_empty subset_image_inj)
             then have "f ` nsets (u ` V) r \<subseteq> h ` nsets V r"
               by (auto simp: h_def)
             then show "f ` nsets (u ` V) r \<subseteq> {j}"
               using hj by auto
             show "(u ` V) \<in> nsets {..<p} (qs ! j)"
               using V j less_2_cases numeral_2_eq_2 qs u_nsets by fastforce
           qed
         next
           case False
           show ?thesis
           proof (intro exI conjI bexI)
             show "Suc i < length qs"
               using Suc.hyps(2) i by auto
             show "f ` nsets U r \<subseteq> {Suc i}"
               using i gi False
               apply (auto simp: g_def image_subset_iff)
               by (metis Suc_lessD Suc_pred g_def gi image_subset_iff not_less_eq singleton_iff)
             show "U \<in> nsets {..<p} (qs ! (Suc i))"
               using False U qs by auto
           qed
         qed
       qed
     qed
   qed
 qed
 
 subsubsection \<open>Simple graph version\<close>
 
 text \<open>This is the most basic version in terms of cliques and independent
   sets, i.e. the version for graphs and 2 colours.
 \<close>
 
 definition "clique V E \<longleftrightarrow> (\<forall>v\<in>V. \<forall>w\<in>V. v \<noteq> w \<longrightarrow> {v, w} \<in> E)"
 definition "indep V E \<longleftrightarrow> (\<forall>v\<in>V. \<forall>w\<in>V. v \<noteq> w \<longrightarrow> {v, w} \<notin> E)"
 
 lemma ramsey2:
   "\<exists>r\<ge>1. \<forall>(V::'a set) (E::'a set set). finite V \<and> card V \<ge> r \<longrightarrow>
     (\<exists>R \<subseteq> V. card R = m \<and> clique R E \<or> card R = n \<and> indep R E)"
 proof -
   obtain N where "N \<ge> Suc 0" and N: "partn_lst {..<N} [m,n] 2"
     using ramsey2_full nat_le_linear partn_lst_greater_resource by blast
   have "\<exists>R\<subseteq>V. card R = m \<and> clique R E \<or> card R = n \<and> indep R E"
     if "finite V" "N \<le> card V" for V :: "'a set" and E :: "'a set set"
   proof -
     from that
     obtain v where u: "inj_on v {..<N}" "v ` {..<N} \<subseteq> V"
       by (metis card_le_inj card_lessThan finite_lessThan)
     define f where "f \<equiv> \<lambda>e. if v ` e \<in> E then 0 else Suc 0"
     have f: "f \<in> nsets {..<N} 2 \<rightarrow> {..<Suc (Suc 0)}"
       by (simp add: f_def)
     then obtain i U where i: "i < 2" and gi: "f ` nsets U 2 \<subseteq> {i}"
       and U: "U \<in> nsets {..<N} ([m,n] ! i)"
       using N numeral_2_eq_2 by (auto simp: partn_lst_def)
     show ?thesis
     proof (intro exI conjI)
       show "v ` U \<subseteq> V"
         using U u by (auto simp: image_subset_iff nsets_def)
       show "card (v ` U) = m \<and> clique (v ` U) E \<or> card (v ` U) = n \<and> indep (v ` U) E"
         using i unfolding numeral_2_eq_2
           using gi U u
           apply (simp add: image_subset_iff nsets_2_eq clique_def indep_def less_Suc_eq)
           apply (auto simp: f_def nsets_def card_image inj_on_subset split: if_split_asm)
           done
     qed
   qed
   then show ?thesis
     using \<open>Suc 0 \<le> N\<close> by auto
 qed
 
 
 subsection \<open>Preliminaries\<close>
 
 subsubsection \<open>``Axiom'' of Dependent Choice\<close>
 
 primrec choice :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> 'a"
   where \<comment> \<open>An integer-indexed chain of choices\<close>
     choice_0: "choice P r 0 = (SOME x. P x)"
   | choice_Suc: "choice P r (Suc n) = (SOME y. P y \<and> (choice P r n, y) \<in> r)"
 
 lemma choice_n:
   assumes P0: "P x0"
     and Pstep: "\<And>x. P x \<Longrightarrow> \<exists>y. P y \<and> (x, y) \<in> r"
   shows "P (choice P r n)"
 proof (induct n)
   case 0
   show ?case by (force intro: someI P0)
 next
   case Suc
   then show ?case by (auto intro: someI2_ex [OF Pstep])
 qed
 
 lemma dependent_choice:
   assumes trans: "trans r"
     and P0: "P x0"
     and Pstep: "\<And>x. P x \<Longrightarrow> \<exists>y. P y \<and> (x, y) \<in> r"
   obtains f :: "nat \<Rightarrow> 'a" where "\<And>n. P (f n)" and "\<And>n m. n < m \<Longrightarrow> (f n, f m) \<in> r"
 proof
   fix n
   show "P (choice P r n)"
     by (blast intro: choice_n [OF P0 Pstep])
 next
   fix n m :: nat
   assume "n < m"
   from Pstep [OF choice_n [OF P0 Pstep]] have "(choice P r k, choice P r (Suc k)) \<in> r" for k
     by (auto intro: someI2_ex)
   then show "(choice P r n, choice P r m) \<in> r"
     by (auto intro: less_Suc_induct [OF \<open>n < m\<close>] transD [OF trans])
 qed
 
 
 subsubsection \<open>Partition functions\<close>
 
 definition part_fn :: "nat \<Rightarrow> nat \<Rightarrow> 'a set \<Rightarrow> ('a set \<Rightarrow> nat) \<Rightarrow> bool"
   \<comment> \<open>the function \<^term>\<open>f\<close> partitions the \<^term>\<open>r\<close>-subsets of the typically
       infinite set \<^term>\<open>Y\<close> into \<^term>\<open>s\<close> distinct categories.\<close>
   where "part_fn r s Y f \<longleftrightarrow> (f \<in> nsets Y r \<rightarrow> {..<s})"
 
 text \<open>For induction, we decrease the value of \<^term>\<open>r\<close> in partitions.\<close>
 lemma part_fn_Suc_imp_part_fn:
   "\<lbrakk>infinite Y; part_fn (Suc r) s Y f; y \<in> Y\<rbrakk> \<Longrightarrow> part_fn r s (Y - {y}) (\<lambda>u. f (insert y u))"
   by (simp add: part_fn_def nsets_def Pi_def subset_Diff_insert)
 
 lemma part_fn_subset: "part_fn r s YY f \<Longrightarrow> Y \<subseteq> YY \<Longrightarrow> part_fn r s Y f"
   unfolding part_fn_def nsets_def by blast
 
 
 subsection \<open>Ramsey's Theorem: Infinitary Version\<close>
 
 lemma Ramsey_induction:
   fixes s r :: nat
     and YY :: "'a set"
     and f :: "'a set \<Rightarrow> nat"
   assumes "infinite YY" "part_fn r s YY f"
   shows "\<exists>Y' t'. Y' \<subseteq> YY \<and> infinite Y' \<and> t' < s \<and> (\<forall>X. X \<subseteq> Y' \<and> finite X \<and> card X = r \<longrightarrow> f X = t')"
   using assms
 proof (induct r arbitrary: YY f)
   case 0
   then show ?case
     by (auto simp add: part_fn_def card_eq_0_iff cong: conj_cong)
 next
   case (Suc r)
   show ?case
   proof -
     from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY"
       by blast
     let ?ramr = "{((y, Y, t), (y', Y', t')). y' \<in> Y \<and> Y' \<subseteq> Y}"
     let ?propr = "\<lambda>(y, Y, t).
                  y \<in> YY \<and> y \<notin> Y \<and> Y \<subseteq> YY \<and> infinite Y \<and> t < s
                  \<and> (\<forall>X. X\<subseteq>Y \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert y) X = t)"
     from Suc.prems have infYY': "infinite (YY - {yy})" by auto
     from Suc.prems have partf': "part_fn r s (YY - {yy}) (f \<circ> insert yy)"
       by (simp add: o_def part_fn_Suc_imp_part_fn yy)
     have transr: "trans ?ramr" by (force simp add: trans_def)
     from Suc.hyps [OF infYY' partf']
     obtain Y0 and t0 where "Y0 \<subseteq> YY - {yy}" "infinite Y0" "t0 < s"
       "X \<subseteq> Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0" for X
       by blast
     with yy have propr0: "?propr(yy, Y0, t0)" by blast
     have proprstep: "\<exists>y. ?propr y \<and> (x, y) \<in> ?ramr" if x: "?propr x" for x
     proof (cases x)
       case (fields yx Yx tx)
       with x obtain yx' where yx': "yx' \<in> Yx"
         by (blast dest: infinite_imp_nonempty)
       from fields x have infYx': "infinite (Yx - {yx'})" by auto
       with fields x yx' Suc.prems have partfx': "part_fn r s (Yx - {yx'}) (f \<circ> insert yx')"
         by (simp add: o_def part_fn_Suc_imp_part_fn part_fn_subset [where YY=YY and Y=Yx])
       from Suc.hyps [OF infYx' partfx'] obtain Y' and t'
         where Y': "Y' \<subseteq> Yx - {yx'}" "infinite Y'" "t' < s"
           "X \<subseteq> Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'" for X
         by blast
       from fields x Y' yx' have "?propr (yx', Y', t') \<and> (x, (yx', Y', t')) \<in> ?ramr"
         by blast
       then show ?thesis ..
     qed
     from dependent_choice [OF transr propr0 proprstep]
     obtain g where pg: "?propr (g n)" and rg: "n < m \<Longrightarrow> (g n, g m) \<in> ?ramr" for n m :: nat
       by blast
     let ?gy = "fst \<circ> g"
     let ?gt = "snd \<circ> snd \<circ> g"
     have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
     proof (intro exI subsetI)
       fix x
       assume "x \<in> range ?gt"
       then obtain n where "x = ?gt n" ..
       with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
     qed
     from rangeg have "finite (range ?gt)"
       by (simp add: finite_nat_iff_bounded)
     then obtain s' and n' where s': "s' = ?gt n'" and infeqs': "infinite {n. ?gt n = s'}"
       by (rule inf_img_fin_domE) (auto simp add: vimage_def intro: infinite_UNIV_nat)
     with pg [of n'] have less': "s'<s" by (cases "g n'") auto
     have inj_gy: "inj ?gy"
     proof (rule linorder_injI)
       fix m m' :: nat
       assume "m < m'"
       from rg [OF this] pg [of m] show "?gy m \<noteq> ?gy m'"
         by (cases "g m", cases "g m'") auto
     qed
     show ?thesis
     proof (intro exI conjI)
       from pg show "?gy ` {n. ?gt n = s'} \<subseteq> YY"
         by (auto simp add: Let_def split_beta)
       from infeqs' show "infinite (?gy ` {n. ?gt n = s'})"
         by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD)
       show "s' < s" by (rule less')
       show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} \<and> finite X \<and> card X = Suc r \<longrightarrow> f X = s'"
       proof -
         have "f X = s'"
           if X: "X \<subseteq> ?gy ` {n. ?gt n = s'}"
           and cardX: "finite X" "card X = Suc r"
           for X
         proof -
           from X obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA"
             by (auto simp add: subset_image_iff)
           with cardX have "AA \<noteq> {}" by auto
           then have AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex)
           show ?thesis
           proof (cases "g (LEAST x. x \<in> AA)")
             case (fields ya Ya ta)
             with AAleast Xeq have ya: "ya \<in> X" by (force intro!: rev_image_eqI)
             then have "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
             also have "\<dots> = ta"
             proof -
               have *: "X - {ya} \<subseteq> Ya"
               proof
                 fix x assume x: "x \<in> X - {ya}"
                 then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA"
                   by (auto simp add: Xeq)
                 with fields x have "a' \<noteq> (LEAST x. x \<in> AA)" by auto
                 with Least_le [of "\<lambda>x. x \<in> AA", OF a'] have "(LEAST x. x \<in> AA) < a'"
                   by arith
                 from xeq fields rg [OF this] show "x \<in> Ya" by auto
               qed
               have "card (X - {ya}) = r"
                 by (simp add: cardX ya)
               with pg [of "LEAST x. x \<in> AA"] fields cardX * show ?thesis
                 by (auto simp del: insert_Diff_single)
             qed
             also from AA AAleast fields have "\<dots> = s'" by auto
             finally show ?thesis .
           qed
         qed
         then show ?thesis by blast
       qed
     qed
   qed
 qed
 
 
 theorem Ramsey:
   fixes s r :: nat
     and Z :: "'a set"
     and f :: "'a set \<Rightarrow> nat"
   shows
    "\<lbrakk>infinite Z;
       \<forall>X. X \<subseteq> Z \<and> finite X \<and> card X = r \<longrightarrow> f X < s\<rbrakk>
     \<Longrightarrow> \<exists>Y t. Y \<subseteq> Z \<and> infinite Y \<and> t < s
             \<and> (\<forall>X. X \<subseteq> Y \<and> finite X \<and> card X = r \<longrightarrow> f X = t)"
   by (blast intro: Ramsey_induction [unfolded part_fn_def nsets_def])
 
 corollary Ramsey2:
   fixes s :: nat
     and Z :: "'a set"
     and f :: "'a set \<Rightarrow> nat"
   assumes infZ: "infinite Z"
     and part: "\<forall>x\<in>Z. \<forall>y\<in>Z. x \<noteq> y \<longrightarrow> f {x, y} < s"
   shows "\<exists>Y t. Y \<subseteq> Z \<and> infinite Y \<and> t < s \<and> (\<forall>x\<in>Y. \<forall>y\<in>Y. x\<noteq>y \<longrightarrow> f {x, y} = t)"
 proof -
   from part have part2: "\<forall>X. X \<subseteq> Z \<and> finite X \<and> card X = 2 \<longrightarrow> f X < s"
     by (fastforce simp add: eval_nat_numeral card_Suc_eq)
   obtain Y t where *:
     "Y \<subseteq> Z" "infinite Y" "t < s" "(\<forall>X. X \<subseteq> Y \<and> finite X \<and> card X = 2 \<longrightarrow> f X = t)"
     by (insert Ramsey [OF infZ part2]) auto
   then have "\<forall>x\<in>Y. \<forall>y\<in>Y. x \<noteq> y \<longrightarrow> f {x, y} = t" by auto
   with * show ?thesis by iprover
 qed
 
 corollary Ramsey_nsets:
   fixes f :: "'a set \<Rightarrow> nat"
   assumes "infinite Z" "f ` nsets Z r \<subseteq> {..<s}"
   obtains Y t where "Y \<subseteq> Z" "infinite Y" "t < s" "f ` nsets Y r \<subseteq> {t}"
   using Ramsey [of Z r f s] assms by (auto simp: nsets_def image_subset_iff)
 
 
 subsection \<open>Disjunctive Well-Foundedness\<close>
 
 text \<open>
   An application of Ramsey's theorem to program termination. See
   @{cite "Podelski-Rybalchenko"}.
 \<close>
 
 definition disj_wf :: "('a \<times> 'a) set \<Rightarrow> bool"
   where "disj_wf r \<longleftrightarrow> (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf (T i)) \<and> r = (\<Union>i<n. T i))"
 
 definition transition_idx :: "(nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> ('a \<times> 'a) set) \<Rightarrow> nat set \<Rightarrow> nat"
   where "transition_idx s T A = (LEAST k. \<exists>i j. A = {i, j} \<and> i < j \<and> (s j, s i) \<in> T k)"
 
 
 lemma transition_idx_less:
   assumes "i < j" "(s j, s i) \<in> T k" "k < n"
   shows "transition_idx s T {i, j} < n"
 proof -
   from assms(1,2) have "transition_idx s T {i, j} \<le> k"
     by (simp add: transition_idx_def, blast intro: Least_le)
   with assms(3) show ?thesis by simp
 qed
 
 lemma transition_idx_in:
   assumes "i < j" "(s j, s i) \<in> T k"
   shows "(s j, s i) \<in> T (transition_idx s T {i, j})"
   using assms
   by (simp add: transition_idx_def doubleton_eq_iff conj_disj_distribR cong: conj_cong) (erule LeastI)
 
 text \<open>To be equal to the union of some well-founded relations is equivalent
   to being the subset of such a union.\<close>
 lemma disj_wf: "disj_wf r \<longleftrightarrow> (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) \<and> r \<subseteq> (\<Union>i<n. T i))"
 proof -
   have *: "\<And>T n. \<lbrakk>\<forall>i<n. wf (T i); r \<subseteq> \<Union> (T ` {..<n})\<rbrakk>
            \<Longrightarrow> (\<forall>i<n. wf (T i \<inter> r)) \<and> r = (\<Union>i<n. T i \<inter> r)"
     by (force simp add: wf_Int1)
   show ?thesis
     unfolding disj_wf_def by auto (metis "*")
 qed
 
 theorem trans_disj_wf_implies_wf:
   assumes "trans r"
     and "disj_wf r"
   shows "wf r"
 proof (simp only: wf_iff_no_infinite_down_chain, rule notI)
   assume "\<exists>s. \<forall>i. (s (Suc i), s i) \<in> r"
   then obtain s where sSuc: "\<forall>i. (s (Suc i), s i) \<in> r" ..
   from \<open>disj_wf r\<close> obtain T and n :: nat where wfT: "\<forall>k<n. wf(T k)" and r: "r = (\<Union>k<n. T k)"
     by (auto simp add: disj_wf_def)
   have s_in_T: "\<exists>k. (s j, s i) \<in> T k \<and> k<n" if "i < j" for i j
   proof -
     from \<open>i < j\<close> have "(s j, s i) \<in> r"
     proof (induct rule: less_Suc_induct)
       case 1
       then show ?case by (simp add: sSuc)
     next
       case 2
       with \<open>trans r\<close> show ?case
         unfolding trans_def by blast
     qed
     then show ?thesis by (auto simp add: r)
   qed
   have "i < j \<Longrightarrow> transition_idx s T {i, j} < n" for i j
     using s_in_T transition_idx_less by blast
   then have trless: "i \<noteq> j \<Longrightarrow> transition_idx s T {i, j} < n" for i j
     by (metis doubleton_eq_iff less_linear)
   have "\<exists>K k. K \<subseteq> UNIV \<and> infinite K \<and> k < n \<and>
       (\<forall>i\<in>K. \<forall>j\<in>K. i \<noteq> j \<longrightarrow> transition_idx s T {i, j} = k)"
     by (rule Ramsey2) (auto intro: trless infinite_UNIV_nat)
   then obtain K and k where infK: "infinite K" and "k < n"
     and allk: "\<forall>i\<in>K. \<forall>j\<in>K. i \<noteq> j \<longrightarrow> transition_idx s T {i, j} = k"
     by auto
   have "(s (enumerate K (Suc m)), s (enumerate K m)) \<in> T k" for m :: nat
   proof -
     let ?j = "enumerate K (Suc m)"
     let ?i = "enumerate K m"
     have ij: "?i < ?j" by (simp add: enumerate_step infK)
     have "?j \<in> K" "?i \<in> K" by (simp_all add: enumerate_in_set infK)
     with ij have k: "k = transition_idx s T {?i, ?j}" by (simp add: allk)
     from s_in_T [OF ij] obtain k' where "(s ?j, s ?i) \<in> T k'" "k'<n" by blast
     then show "(s ?j, s ?i) \<in> T k" by (simp add: k transition_idx_in ij)
   qed
   then have "\<not> wf (T k)"
     by (meson wf_iff_no_infinite_down_chain)
   with wfT \<open>k < n\<close> show False by blast
 qed
 
 end