# HG changeset patch
# User paulson <lp15@cam.ac.uk>
# Date 1538663147 -3600
# Node ID 1b5178abaf97c06db00a35f79610cf8379836c2e
# Parent  12dce58bcd3f970563c6465d6c52684cfb0771cb
updates to Algebra from Baillon and de Vilhena

diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Chinese_Remainder.thy
--- a/src/HOL/Algebra/Chinese_Remainder.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Chinese_Remainder.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -3,1140 +3,507 @@
 *)
 
 theory Chinese_Remainder
-  imports QuotRing Ideal_Product
+  imports Weak_Morphisms Ideal_Product
+    
 begin
 
-section \<open>Chinese Remainder Theorem\<close>
 
-subsection \<open>Direct Product of Rings\<close>
+section \<open>Direct Product of Rings\<close>
+
+subsection \<open>Definitions\<close>
 
-definition
-  RDirProd :: "[ ('a, 'n) ring_scheme, ('b, 'm) ring_scheme ]  \<Rightarrow> ('a \<times> 'b) ring"
-  where "RDirProd R S =
-           \<lparr> carrier = carrier R \<times> carrier S,
-                mult = (\<lambda>(r, s). \<lambda>(r', s'). (r \<otimes>\<^bsub>R\<^esub> r', s \<otimes>\<^bsub>S\<^esub> s')),
-                 one = (\<one>\<^bsub>R\<^esub>, \<one>\<^bsub>S\<^esub>),
-                zero = (\<zero>\<^bsub>R\<^esub>, \<zero>\<^bsub>S\<^esub>),
-                 add = (\<lambda>(r, s). \<lambda>(r', s'). (r \<oplus>\<^bsub>R\<^esub> r', s \<oplus>\<^bsub>S\<^esub> s')) \<rparr>"
+definition RDirProd :: "('a, 'n) ring_scheme \<Rightarrow> ('b, 'm) ring_scheme \<Rightarrow> ('a \<times> 'b) ring"
+  where "RDirProd R S = monoid.extend (R \<times>\<times> S)
+           \<lparr> zero = one ((add_monoid R) \<times>\<times> (add_monoid S)),
+              add = mult ((add_monoid R) \<times>\<times> (add_monoid S)) \<rparr> "
+
+abbreviation nil_ring :: "('a list) ring"
+  where "nil_ring \<equiv> monoid.extend nil_monoid \<lparr> zero = [], add = (\<lambda>a b. []) \<rparr>"
+
+definition RDirProd_list :: "(('a, 'n) ring_scheme) list \<Rightarrow> ('a list) ring"
+  where "RDirProd_list Rs = foldr (\<lambda>R S. image_ring (\<lambda>(a, as). a # as) (RDirProd R S)) Rs nil_ring"
+
 
-lemma RDirProd_monoid:
-  assumes "ring R" and "ring S"
-  shows "monoid (RDirProd R S)"
-  by (rule monoidI) (auto simp add: RDirProd_def assms ring.ring_simprules ring.is_monoid)
+subsection \<open>Basic Properties\<close>
+
+lemma RDirProd_carrier: "carrier (RDirProd R S) = carrier R \<times> carrier S"
+  unfolding RDirProd_def DirProd_def by (simp add: monoid.defs)
+
+lemma RDirProd_add_monoid [simp]: "add_monoid (RDirProd R S) = (add_monoid R) \<times>\<times> (add_monoid S)"
+  by (simp add: RDirProd_def monoid.defs)
 
-lemma RDirProd_abelian_group:
-  assumes "ring R" and "ring S"
-  shows "abelian_group (RDirProd R S)"
-  by (auto intro!: abelian_groupI
-         simp add: RDirProd_def assms ring.ring_simprules)
-     (meson assms ring.ring_simprules(3,16))+
-
-lemma RDirProd_group:
-  assumes "ring R" and "ring S"
-  shows "ring (RDirProd R S)"
+lemma RDirProd_ring:
+  assumes "ring R" and "ring S" shows "ring (RDirProd R S)"
 proof -
+  have "monoid (RDirProd R S)"
+    using DirProd_monoid[OF assms[THEN ring.axioms(2)]] unfolding monoid_def
+    by (auto simp add: DirProd_def RDirProd_def monoid.defs)
+  then interpret Prod: group "add_monoid (RDirProd R S)" + monoid "RDirProd R S"
+    using DirProd_group[OF assms[THEN abelian_group.a_group[OF ring.is_abelian_group]]]
+    unfolding RDirProd_add_monoid by auto
   show ?thesis
-    apply (rule ringI)
-    apply (simp_all add: assms RDirProd_abelian_group RDirProd_monoid)
-    by (auto simp add: RDirProd_def assms ring.ring_simprules)
+    by (unfold_locales, auto simp add: RDirProd_def DirProd_def monoid.defs assms ring.ring_simprules)
 qed
 
-lemma RDirProd_isomorphism1:
+lemma RDirProd_iso1:
   "(\<lambda>(x, y). (y, x)) \<in> ring_iso (RDirProd R S) (RDirProd S R)"
-  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def RDirProd_def by auto
+  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
+  by (auto simp add: RDirProd_def DirProd_def monoid.defs)
 
-lemma RDirProd_isomorphism2:
+lemma RDirProd_iso2:
   "(\<lambda>(x, (y, z)). ((x, y), z)) \<in> ring_iso (RDirProd R (RDirProd S T)) (RDirProd (RDirProd R S) T)"
-  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def RDirProd_def
-  by (auto simp add: image_iff)
+  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
+  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)
 
-lemma RDirProd_isomorphism3:
+lemma RDirProd_iso3:
   "(\<lambda>((x, y), z). (x, (y, z))) \<in> ring_iso (RDirProd (RDirProd R S) T) (RDirProd R (RDirProd S T))"
-  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def RDirProd_def
-  by (auto simp add: image_iff)
+  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
+  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)
 
-lemma RDirProd_isomorphism4:
-  assumes "f \<in> ring_iso R S"
-  shows "(\<lambda>(r, t). (f r, t)) \<in> ring_iso (RDirProd R T) (RDirProd S T)"
-  using assms unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def RDirProd_def
-  by (auto simp add: image_iff)+
+lemma RDirProd_iso4:
+  assumes "f \<in> ring_iso R S" shows "(\<lambda>(r, t). (f r, t)) \<in> ring_iso (RDirProd R T) (RDirProd S T)"
+  using assms unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
+  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)+
 
-lemma RDirProd_isomorphism5:
-  assumes "f \<in> ring_iso S T"
-  shows "(\<lambda>(r, s). (r, f s)) \<in> ring_iso (RDirProd R S) (RDirProd R T)"
-  using ring_iso_set_trans[OF ring_iso_set_trans[OF RDirProd_isomorphism1[of R S]
-                                                    RDirProd_isomorphism4[OF assms, of R]]
-                              RDirProd_isomorphism1[of T R]]
+lemma RDirProd_iso5:
+  assumes "f \<in> ring_iso S T" shows "(\<lambda>(r, s). (r, f s)) \<in> ring_iso (RDirProd R S) (RDirProd R T)"
+  using ring_iso_set_trans[OF ring_iso_set_trans[OF RDirProd_iso1 RDirProd_iso4[OF assms]] RDirProd_iso1]
   by (simp add: case_prod_unfold comp_def)
 
-lemma RDirProd_isomorphism6:
+lemma RDirProd_iso6:
   assumes "f \<in> ring_iso R R'" and "g \<in> ring_iso S S'"
   shows "(\<lambda>(r, s). (f r, g s)) \<in> ring_iso (RDirProd R S) (RDirProd R' S')"
-  using ring_iso_set_trans[OF RDirProd_isomorphism4[OF assms(1)] RDirProd_isomorphism5[OF assms(2)]]
+  using ring_iso_set_trans[OF RDirProd_iso4[OF assms(1)] RDirProd_iso5[OF assms(2)]]
+  by (simp add: case_prod_beta' comp_def)
+
+lemma RDirProd_iso7:
+  shows "(\<lambda>a. (a, [])) \<in> ring_iso R (RDirProd R nil_ring)"
+  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
+  by (auto simp add: RDirProd_def DirProd_def monoid.defs)
+
+lemma RDirProd_hom1:
+  shows "(\<lambda>a. (a, a)) \<in> ring_hom R (RDirProd R R)"
+  by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)
+
+lemma RDirProd_hom2:
+  assumes "f \<in> ring_hom S T"
+  shows "(\<lambda>(x, y). (x, f y)) \<in> ring_hom (RDirProd R S) (RDirProd R T)"
+    and "(\<lambda>(x, y). (f x, y)) \<in> ring_hom (RDirProd S R) (RDirProd T R)"
+  using assms by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)
+
+lemma RDirProd_hom3:
+  assumes "f \<in> ring_hom R R'" and "g \<in> ring_hom S S'"
+  shows "(\<lambda>(r, s). (f r, g s)) \<in> ring_hom (RDirProd R S) (RDirProd R' S')"
+  using ring_hom_trans[OF RDirProd_hom2(2)[OF assms(1)] RDirProd_hom2(1)[OF assms(2)]]
   by (simp add: case_prod_beta' comp_def)
 
 
-subsection \<open>Simple Version of The Theorem\<close>
-
-text \<open>We start by proving a simpler version of the theorem. The rest of the theory is
-      dedicated to its generalization\<close>
+subsection \<open>Direct Product of a List of Rings\<close>
 
-lemma (in ideal) set_add_zero:
-  assumes "i \<in> I"
-  shows "I +> i = I"
-  by (simp add: a_rcos_const assms)
+lemma RDirProd_list_nil [simp]: "RDirProd_list [] = nil_ring"
+  unfolding RDirProd_list_def by simp
 
-lemma (in ideal) set_add_zero_imp_mem:
-  assumes "i \<in> carrier R" "I +> i = I"
-  shows "i \<in> I"
-  using a_rcos_self assms(1-2) by auto
+lemma nil_ring_simprules [simp]:
+  "carrier nil_ring = { [] }" and "one nil_ring = []" and "zero nil_ring = []"
+  by (auto simp add: monoid.defs)
 
-lemma (in ring) canonical_proj_is_surj:
-  assumes "ideal I R" "ideal J R" "I <+> J = carrier R"
-  shows "\<And>x y. \<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow>
-                 \<exists>a \<in> carrier R. I +> a = I +> x \<and> J +> a = J +> y"
-proof -
-  { fix I J i j assume A: "ideal I R" "ideal J R" "i \<in> I" "j \<in> J" "\<one> = i \<oplus> j"
-    have "I +> \<one> = I +> j"
-    proof -
-      have "I +> \<one> = I +> (i \<oplus> j)" using A(5) by simp
-      also have " ... = (I +> i) <+> (I +> j)"
-        by (metis abelian_subgroup.a_rcos_sum abelian_subgroupI3 A(1-4)
-            ideal.Icarr ideal.axioms(1) is_abelian_group)
-      also have " ... = (I +> \<zero>) <+> (I +> j)"
-        using ideal.set_add_zero[OF A(1) A(3)]
-        by (simp add: A(1) additive_subgroup.a_subset ideal.axioms(1)) 
-      also have " ... = I +> (\<zero> \<oplus> j)"
-        by (meson A abelian_subgroup.a_rcos_sum abelian_subgroupI3
-            additive_subgroup.a_Hcarr ideal.axioms(1) is_abelian_group zero_closed)
-      finally show "I +> \<one> = I +> j"
-        using A(2) A(4) ideal.Icarr by fastforce
-    qed } note aux_lemma = this
-  
-  fix x y assume x: "x \<in> carrier R" and y: "y \<in> carrier R"
-  
-  have "\<one> \<in> I <+> J" using assms by simp
-  then obtain i j where i: "i \<in> I" and j: "j \<in> J" and ij: "\<one> = i \<oplus> j"
-    using set_add_def'[of R I J] by auto
-  have mod_I: "I +> j = I +> \<one>" and mod_J: "J +> i = J +> \<one>"
-    using aux_lemma[OF assms(1-2) i j ij] apply simp
-    using aux_lemma[OF assms(2) assms(1) j i] ij
-    by (metis add.m_comm assms(1) assms(2) i ideal.Icarr j)
-
-  have "I +> ((j \<otimes> x) \<oplus> (i \<otimes> y)) = (I +> (j \<otimes> x)) <+> (I +> (i \<otimes> y))"
-    by (metis abelian_subgroup.a_rcos_sum abelian_subgroupI3 assms i ideal.Icarr
-        ideal.axioms(1) is_abelian_group j m_closed x y)
-  also have " ... = (I +> (j \<otimes> x)) <+> (I +> \<zero>)"
-    using ideal.set_add_zero[OF assms(1), of "i \<otimes> y"] i assms(1)
-    by (simp add: additive_subgroup.a_subset ideal.I_r_closed ideal.axioms(1) y)
-  also have " ... = I +> (j \<otimes> x)"
-    by (metis abelian_subgroup.a_rcos_sum abelian_subgroupI3 additive_subgroup.a_Hcarr assms(1-2)
-        ideal.axioms(1) is_abelian_group j m_closed r_zero x zero_closed)
-  finally have Ix: "I +> ((j \<otimes> x) \<oplus> (i \<otimes> y)) = I +> x" using mod_I
-    by (metis (full_types) assms ideal.Icarr ideal.rcoset_mult_add is_monoid j monoid.l_one one_closed x)
-  have "J +> ((j \<otimes> x) \<oplus> (i \<otimes> y)) = (J +> (j \<otimes> x)) <+> (J +> (i \<otimes> y))"
-    by (metis abelian_subgroup.a_rcos_sum abelian_subgroupI3 assms i ideal.Icarr
-        ideal.axioms(1) is_abelian_group j m_closed x y)
-  also have " ... = (J +> \<zero>) <+> (J +> (i \<otimes> y))"
-    using ideal.set_add_zero[OF assms(2), of "j \<otimes> x"] j assms(2)
-    by (simp add: additive_subgroup.a_subset ideal.I_r_closed ideal.axioms(1) x)
-  also have " ... = J +> (i \<otimes> y)"
-    by (metis a_coset_add_zero a_rcosetsI abelian_subgroup.rcosets_add_eq abelian_subgroupI3
-        additive_subgroup.a_Hcarr additive_subgroup.a_subset assms i ideal.axioms(1)
-        is_abelian_group m_closed y)
-  finally have Jy: "J +> ((j \<otimes> x) \<oplus> (i \<otimes> y)) = J +> y" using mod_J
-    by (metis (full_types) assms i ideal.Icarr ideal.rcoset_mult_add local.semiring_axioms one_closed semiring.semiring_simprules(9) y)  
-  have "(j \<otimes> x) \<oplus> (i \<otimes> y) \<in> carrier R"
-    by (meson x y i j assms add.m_closed additive_subgroup.a_Hcarr ideal.axioms(1) m_closed)
-  thus "\<exists>a \<in> carrier R. I +> a = I +> x \<and> J +> a = J +> y" using Ix Jy by blast
+lemma RDirProd_list_truncate:
+  shows "monoid.truncate (RDirProd_list Rs) = DirProd_list Rs"
+proof (induct Rs, simp add: RDirProd_list_def DirProd_list_def monoid.defs)
+  case (Cons R Rs)
+  have "monoid.truncate (RDirProd_list (R # Rs)) =
+        monoid.truncate (image_ring (\<lambda>(a, as). a # as) (RDirProd R (RDirProd_list Rs)))"
+    unfolding RDirProd_list_def by simp
+  also have " ... = image_group (\<lambda>(a, as). a # as) (monoid.truncate (RDirProd R (RDirProd_list Rs)))"
+  by (simp add: image_ring_def image_group_def monoid.defs)
+  also have " ... = image_group (\<lambda>(a, as). a # as) (R \<times>\<times> (monoid.truncate (RDirProd_list Rs)))"
+    by (simp add: RDirProd_def DirProd_def monoid.defs)
+  also have " ... = DirProd_list (R # Rs)"
+    unfolding Cons DirProd_list_def by simp
+  finally show ?case .
 qed
 
-lemma (in ring) canonical_proj_is_hom:
-  assumes "ideal I R" "ideal J R" "I <+> J = carrier R"
-  shows "(\<lambda>a. (I +> a, J +> a)) \<in> ring_hom R (RDirProd (R Quot I) (R Quot J))"
-proof (rule ring_hom_memI)
-  fix x y assume x: "x \<in> carrier R" and y: "y \<in> carrier R"
-  show "(I +> x, J +> x) \<in> carrier (RDirProd (R Quot I) (R Quot J))"
-    using A_RCOSETS_def'[of R I] A_RCOSETS_def'[of R J] x
-    unfolding RDirProd_def FactRing_def by auto
-  show "(I +> x \<otimes> y, J +> x \<otimes> y) =
-        (I +> x, J +> x) \<otimes>\<^bsub>RDirProd (R Quot I) (R Quot J)\<^esub> (I +> y, J +> y)"
-    unfolding RDirProd_def FactRing_def by (simp add: assms ideal.rcoset_mult_add x y)
-  show "(I +> x \<oplus> y, J +> x \<oplus> y) =
-        (I +> x, J +> x) \<oplus>\<^bsub>RDirProd (R Quot I) (R Quot J)\<^esub> (I +> y, J +> y)"
-    unfolding RDirProd_def FactRing_def
-    by (simp add: abelian_subgroup.a_rcos_sum abelian_subgroupI3 assms ideal.axioms(1) is_abelian_group x y)
-next
-  show "(I +> \<one>, J +> \<one>) = \<one>\<^bsub>RDirProd (R Quot I) (R Quot J)\<^esub>"
-    unfolding RDirProd_def FactRing_def by simp
+lemma RDirProd_list_carrier_def':
+  shows "carrier (RDirProd_list Rs) = carrier (DirProd_list Rs)"
+proof -
+  have "carrier (RDirProd_list Rs) = carrier (monoid.truncate (RDirProd_list Rs))"
+    by (simp add: monoid.defs)
+  thus ?thesis
+    unfolding RDirProd_list_truncate .
 qed
 
-theorem (in ring) chinese_remainder_simple:
-  assumes "ideal I R" "ideal J R" "I <+> J = carrier R"
-  shows "(R Quot (I \<inter> J)) \<simeq> (RDirProd (R Quot I) (R Quot J))"
-proof -
-  let ?\<phi> = "\<lambda>a. (I +> a, J +> a)"
+lemma RDirProd_list_carrier:
+  shows "carrier (RDirProd_list (G # Gs)) = (\<lambda>(x, xs). x # xs) ` (carrier G \<times> carrier (RDirProd_list Gs))"
+  unfolding RDirProd_list_carrier_def' using DirProd_list_carrier .
+
+lemma RDirProd_list_one:
+  shows "one (RDirProd_list Rs) = foldr (\<lambda>R tl. (one R) # tl) Rs []"
+  unfolding RDirProd_list_def RDirProd_def image_ring_def image_group_def
+  by (induct Rs) (auto simp add: monoid.defs)
 
-  have phi_hom: "?\<phi> \<in> ring_hom R (RDirProd (R Quot I) (R Quot J))"
-    using canonical_proj_is_hom[OF assms] .
+lemma RDirProd_list_zero:
+  shows "zero (RDirProd_list Rs) = foldr (\<lambda>R tl. (zero R) # tl) Rs []"
+  unfolding RDirProd_list_def RDirProd_def image_ring_def
+  by (induct Rs) (auto simp add: monoid.defs)
+
+lemma RDirProd_list_zero':
+  shows "zero (RDirProd_list (R # Rs)) = (zero R) # (zero (RDirProd_list Rs))"
+  unfolding RDirProd_list_zero by simp
+
+lemma RDirProd_list_carrier_mem:
+  assumes "as \<in> carrier (RDirProd_list Rs)"
+  shows "length as = length Rs" and "\<And>i. i < length Rs \<Longrightarrow> (as ! i) \<in> carrier (Rs ! i)"
+  using assms DirProd_list_carrier_mem unfolding RDirProd_list_carrier_def' by auto
 
-  moreover have "?\<phi> ` (carrier R) = carrier (RDirProd (R Quot I) (R Quot J))"
-  proof
-    show "carrier (RDirProd (R Quot I) (R Quot J)) \<subseteq> ?\<phi> ` (carrier R)"
-    proof
-      fix t assume "t \<in> carrier (RDirProd (R Quot I) (R Quot J))"
-      then obtain x y where x: "x \<in> carrier R" and y: "y \<in> carrier R"
-                        and t: "t = (I +> x, J +> y)"
-        using A_RCOSETS_def'[of R I] A_RCOSETS_def'[of R J]
-        unfolding RDirProd_def FactRing_def by auto
-      then obtain a where "a \<in> carrier R" "I +> a = I +> x" "J +> a = J +> y"
-        using canonical_proj_is_surj[OF assms x y] by blast
-      hence "?\<phi> a = t" using t by simp
-      thus "t \<in> (?\<phi> ` carrier R)" using \<open>a \<in> carrier R\<close> by blast
-    qed
-  next
-    show "?\<phi> ` carrier R \<subseteq> carrier (RDirProd (R Quot I) (R Quot J))"
-      using phi_hom unfolding ring_hom_def by blast
-  qed
+lemma RDirProd_list_carrier_memI:
+  assumes "length as = length Rs" and "\<And>i. i < length Rs \<Longrightarrow> (as ! i) \<in> carrier (Rs ! i)"
+  shows "as \<in> carrier (RDirProd_list Rs)"
+  using assms DirProd_list_carrier_memI unfolding RDirProd_list_carrier_def' by auto
+
+lemma inj_on_RDirProd_carrier:
+  shows "inj_on (\<lambda>(a, as). a # as) (carrier (RDirProd R (RDirProd_list Rs)))"
+  unfolding RDirProd_def DirProd_def inj_on_def by auto
 
-  moreover have "a_kernel R (RDirProd (R Quot I) (R Quot J)) ?\<phi> = I \<inter> J"
-  proof
-    show "I \<inter> J \<subseteq> a_kernel R (RDirProd (R Quot I) (R Quot J)) ?\<phi>"
-    proof
-      fix s assume s: "s \<in> I \<inter> J" hence "I +> s = I \<and> J +> s = J"
-        by (simp add: additive_subgroup.zero_closed assms ideal.axioms(1) ideal.set_add_zero)
-      thus "s \<in> a_kernel R (RDirProd (R Quot I) (R Quot J)) ?\<phi>"
-        unfolding FactRing_def RDirProd_def a_kernel_def kernel_def
-        using s additive_subgroup.a_Hcarr assms(1) ideal.axioms(1) by fastforce
-    qed
-  next
-    show "a_kernel R (RDirProd (R Quot I) (R Quot J)) ?\<phi> \<subseteq> I \<inter> J"
-    unfolding FactRing_def RDirProd_def a_kernel_def kernel_def apply simp
-    using ideal.set_add_zero_imp_mem assms(1-2) by fastforce
-  qed
-
-  moreover have "ring (RDirProd (R Quot I) (R Quot J))"
-    by (simp add: RDirProd_group assms(1) assms(2) ideal.quotient_is_ring) 
-
-  ultimately show ?thesis
-    using ring_hom_ring.FactRing_iso[of R "RDirProd (R Quot I) (R Quot J)" ?\<phi>] is_ring
-    by (simp add: ring_hom_ringI2)
+lemma RDirProd_list_is_ring:
+  assumes "\<And>i. i < length Rs \<Longrightarrow> ring (Rs ! i)" shows "ring (RDirProd_list Rs)"
+  using assms
+proof (induct Rs)
+  case Nil thus ?case
+    unfolding RDirProd_list_def by (unfold_locales, auto simp add: monoid.defs Units_def)
+next
+  case (Cons R Rs)
+  hence is_ring: "ring (RDirProd R (RDirProd_list Rs))"
+    using RDirProd_ring[of R "RDirProd_list Rs"] by force
+  show ?case
+    using ring.inj_imp_image_ring_is_ring[OF is_ring inj_on_RDirProd_carrier]
+    unfolding RDirProd_list_def by auto 
 qed
 
+lemma RDirProd_list_iso1:
+  "(\<lambda>(a, as). a # as) \<in> ring_iso (RDirProd R (RDirProd_list Rs)) (RDirProd_list (R # Rs))"
+  using inj_imp_image_ring_iso[OF inj_on_RDirProd_carrier] unfolding RDirProd_list_def by auto
 
-subsection \<open>First Generalization - The Extended Canonical Projection is Surjective\<close>
+lemma RDirProd_list_iso2:
+  "Hilbert_Choice.inv (\<lambda>(a, as). a # as) \<in> ring_iso (RDirProd_list (R # Rs)) (RDirProd R (RDirProd_list Rs))"
+  unfolding RDirProd_list_def by (auto intro: inj_imp_image_ring_inv_iso simp add: inj_def)
 
-lemma (in cring) canonical_proj_ext_is_surj:
-  fixes n::nat
-  assumes "\<And>i. i \<le> n \<Longrightarrow> x i \<in> carrier R"
-      and "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R"
-      and "\<And>i j. \<lbrakk> i \<le> n; j \<le> n; i \<noteq> j \<rbrakk> \<Longrightarrow> I i <+> I j = carrier R"
-    shows "\<exists> a \<in> carrier R. \<forall> i \<le> n. (I i) +> a = (I i) +> (x i)" using assms
-proof (induct n)
-  case 0 thus ?case by blast 
-next
-  case (Suc n)
-  then obtain a where a: "a \<in> carrier R" "\<And>i. i \<le> n \<Longrightarrow> (I i) +> a = (I i) +> (x i)"
-    by force
-  
-  have inter_is_ideal: "ideal (\<Inter> i \<le> n. I i) R"
-    by (metis (mono_tags, lifting) Suc.prems(2) atMost_iff i_Intersect imageE image_is_empty le_SucI not_empty_eq_Iic_eq_empty)
-  have "(\<Inter> i \<le> n. I i) <+> I (Suc n) = carrier R"
-    using inter_plus_ideal_eq_carrier Suc by simp
-  then obtain b where b: "b \<in> carrier R"
-                  and "(\<Inter> i \<le> n. I i) +> b = (\<Inter> i \<le> n. I i) +> \<zero>"
-                  and S: "I (Suc n) +> b = I (Suc n) +> (x (Suc n) \<ominus> a)"
-    using canonical_proj_is_surj[OF inter_is_ideal, of "I (Suc n)" \<zero> "x (Suc n) \<ominus> a"] Suc a by auto
-  hence b_inter: "b \<in> (\<Inter> i \<le> n. I i)"
-    using ideal.set_add_zero_imp_mem[OF inter_is_ideal b]
-    by (metis additive_subgroup.zero_closed ideal.axioms(1) ideal.set_add_zero inter_is_ideal)
-  hence eq_zero: "\<And>i. i \<le> n \<Longrightarrow> (I i) +> b = (I i) +> \<zero>"
-  proof -
-    fix i assume i: "i \<le> n"
-    hence "b \<in> I i" using  b_inter by blast
-    moreover have "ideal (I i) R" using Suc i by simp 
-    ultimately show "(I i) +> b = (I i) +> \<zero>"
-      by (metis b ideal.I_r_closed ideal.set_add_zero r_null zero_closed)
-  qed
-  
-  have "(I i) +> (a \<oplus> b) = (I i) +> (x i)" if "i \<le> Suc n" for i
-  proof -
-    show "(I i) +> (a \<oplus> b) = (I i) +> (x i)"
-      using that
-    proof (cases)
-      assume 1: "i \<le> n"
-      hence "(I i) +> (a \<oplus> b) = ((I i) +> (x i)) <+> ((I i) +> b)"
-        by (metis Suc.prems(2) a abelian_subgroup.a_rcos_sum abelian_subgroupI3 b ideal_def le_SucI ring_def)
-      also have " ... = ((I i) +> (x i)) <+> ((I i) +> \<zero>)"
-        using eq_zero[OF 1] by simp
-      also have " ... = I i +> ((x i) \<oplus> \<zero>)"
-        by (meson Suc.prems abelian_subgroup.a_rcos_sum abelian_subgroupI3 atMost_iff that ideal_def ring_def zero_closed)
-      finally show "(I i) +> (a \<oplus> b) = (I i) +> (x i)"
-        using Suc.prems(1) that by auto
-    next
-      assume "\<not> i \<le> n" hence 2: "i = Suc n" using that by simp
-      hence "I i +> (a \<oplus> b) = I (Suc n) +> (a \<oplus> b)" by simp
-      also have " ... = (I (Suc n) +> a) <+> (I (Suc n) +> (x (Suc n) \<ominus> a))"
-        by (metis le_Suc_eq S a b Suc.prems(2)[of "Suc n"] 2 abelian_subgroup.a_rcos_sum
-              abelian_subgroupI3 ideal.axioms(1) is_abelian_group)
-      also have " ... = I (Suc n) +> (a \<oplus> (x (Suc n) \<ominus> a))"
-        by (simp add: Suc.prems(1-2) a(1) abelian_subgroup.a_rcos_sum
-                      abelian_subgroupI3 ideal.axioms(1) is_abelian_group)
-      also have " ... = I (Suc n) +> (x (Suc n))"
-        using a(1) Suc.prems(1)[of "Suc n"] abelian_group.minus_eq
-              abelian_group.r_neg add.m_lcomm is_abelian_group by fastforce
-      finally show "I i +> (a \<oplus> b) = (I i) +> (x i)" using 2 by simp
-    qed
-  qed
-  thus ?case using a b by auto
+lemma RDirProd_list_iso3:
+  "(\<lambda>a. [ a ]) \<in> ring_iso R (RDirProd_list [ R ])"
+proof -
+  have [simp]: "(\<lambda>a. [ a ]) = (\<lambda>(a, as). a # as) \<circ> (\<lambda>a. (a, []))" by auto
+  show ?thesis
+    using ring_iso_set_trans[OF RDirProd_iso7] RDirProd_list_iso1[of R "[]"]
+    unfolding RDirProd_list_def by simp
+qed
+
+lemma RDirProd_list_hom1:
+  "(\<lambda>(a, as). a # as) \<in> ring_hom (RDirProd R (RDirProd_list Rs)) (RDirProd_list (R # Rs))"
+  using RDirProd_list_iso1 unfolding ring_iso_def by auto
+
+lemma RDirProd_list_hom2:
+  assumes "f \<in> ring_hom R S" shows "(\<lambda>a. [ f a ]) \<in> ring_hom R (RDirProd_list [ S ])"
+proof -
+  have hom1: "(\<lambda>a. (a, [])) \<in> ring_hom R (RDirProd R nil_ring)"
+    using RDirProd_iso7 unfolding ring_iso_def by auto
+  have hom2: "(\<lambda>(a, as). a # as) \<in> ring_hom (RDirProd S nil_ring) (RDirProd_list [ S ])"
+    using RDirProd_list_hom1[of _ "[]"] unfolding RDirProd_list_def by auto
+  have [simp]: "(\<lambda>(a, as). a # as) \<circ> ((\<lambda>(x, y). (f x, y)) \<circ> (\<lambda>a. (a, []))) = (\<lambda>a. [ f a ])" by auto
+  show ?thesis
+    using ring_hom_trans[OF ring_hom_trans[OF hom1 RDirProd_hom2(2)[OF assms]] hom2] by simp
 qed
 
 
-subsection \<open>Direct Product of a List of Monoid Structures\<close>
-
-fun DirProd_list :: "(('a, 'b) monoid_scheme) list \<Rightarrow> (('a list), 'b) monoid_scheme"
-  where
-    "DirProd_list [] = \<lparr> carrier = {[]}, mult = (\<lambda>a b. []), one = [], \<dots> = (undefined :: 'b) \<rparr>"
-  | "DirProd_list (Cons R Rs) =
-      \<lparr> carrier = { r # rs | r rs. r \<in> carrier R \<and> rs \<in> carrier (DirProd_list Rs) },
-           mult = (\<lambda>r1 r2. ((hd r1) \<otimes>\<^bsub>R\<^esub> (hd r2)) # ((tl r1) \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> (tl r2))),
-            one = (\<one>\<^bsub>R\<^esub>) # (\<one>\<^bsub>(DirProd_list Rs)\<^esub>), \<dots> = (undefined :: 'b) \<rparr>"
-
-
-lemma DirProd_list_carrier_elts:
-  assumes "rs \<in> carrier (DirProd_list Rs)"
-    shows "length rs = length Rs" using assms
-proof (induct Rs arbitrary: rs rule: DirProd_list.induct)
-  case 1 thus ?case by simp
-next
-  case (2 R Rs)
-  then obtain r' rs' where "r' \<in> carrier R" "rs' \<in> carrier (DirProd_list Rs)"
-                       and "rs = r' # rs'" by auto
-  thus ?case by (simp add: "2.hyps"(1))
-qed
-
-lemma DirProd_list_in_carrierI:
-  assumes "\<And>i. i < length rs \<Longrightarrow> rs ! i \<in> carrier (Rs ! i)"
-    and "length rs = length Rs"
-  shows "rs \<in> carrier (DirProd_list Rs)" using assms
-proof (induct Rs arbitrary: rs rule: DirProd_list.induct)
-  case 1 thus ?case by simp
-next
-  case (2 R Rs)
-  then obtain r' rs' where rs: "r' \<in> carrier R" "rs = r' # rs'"
-    by (metis Suc_length_conv lessThan_iff nth_Cons_0 zero_less_Suc)
-  hence "rs' \<in> carrier (DirProd_list Rs)"
-    using "2.hyps"(1) "2.prems"(1) "2.prems"(2) by force
-  thus ?case by (simp add: rs)
-qed
-
-lemma DirProd_list_in_carrierE:
-  assumes "rs \<in> carrier (DirProd_list Rs)"
-  shows "\<And>i. i < length rs \<Longrightarrow> rs ! i \<in> carrier (Rs ! i)" using assms
-proof (induct Rs arbitrary: rs rule: DirProd_list.induct)
-  case 1 thus ?case by simp 
-next
-  case (2 R Rs)
-  then obtain r' rs' where  r': " r' \<in> carrier R"
-                       and rs': "rs' \<in> carrier (DirProd_list Rs)"
-                       and  rs: "rs = r' # rs'" by auto
-  hence "\<And>i. i \<in> {..<(length rs')} \<Longrightarrow> rs' ! i \<in> carrier (Rs ! i)"
-    using "2.hyps"(1) by blast
-  hence "\<And>i. i \<in> {(Suc 0 :: nat)..<(length rs)} \<Longrightarrow> rs ! i \<in> carrier ((R # Rs) ! i)"
-    by (simp add: less_eq_Suc_le rs)
-  moreover have "i = 0 \<Longrightarrow> rs ! i \<in> carrier ((R # Rs) ! i)"
-    using r' rs r' by simp
-  ultimately show ?case
-    using "2.prems"(1) by fastforce   
-qed
+section \<open>Chinese Remainder Theorem\<close>
 
-lemma DirProd_list_m_closed:
-  assumes "r1 \<in> carrier (DirProd_list Rs)" "r2 \<in> carrier (DirProd_list Rs)"
-    and "\<And>i. i < length Rs \<Longrightarrow> monoid (Rs ! i)"
-  shows "r1 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r2 \<in> carrier (DirProd_list Rs)" using assms
-proof (induct Rs arbitrary: r1 r2 rule: DirProd_list.induct)
-  case 1 thus ?case by simp 
-next
-  case (2 R Rs)
-  then obtain r1' rs1' r2' rs2'
-    where r12': "r1' \<in> carrier R" "r2' \<in> carrier R"
-      and "rs1' \<in> carrier (DirProd_list Rs)"
-      and "rs2' \<in> carrier (DirProd_list Rs)"
-      and r1: "r1 = r1' # rs1'"
-      and r2: "r2 = r2' # rs2'" by auto
-  moreover have "\<And>i. i < length Rs \<Longrightarrow> monoid (Rs ! i)"
-    using "2.prems"(3) by force
-  ultimately have "rs1' \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> rs2' \<in> carrier (DirProd_list Rs)"
-    using "2.hyps"(1) by blast
-  moreover have "monoid R"
-    using "2.prems"(3) by force
-  hence "r1' \<otimes>\<^bsub>R\<^esub> r2' \<in> carrier R"
-    by (simp add: r12' monoid.m_closed)
-  ultimately show ?case by (simp add: r1 r2)
-qed
-
-lemma DirProd_list_m_output:
-  assumes "r1 \<in> carrier (DirProd_list Rs)" "r2 \<in> carrier (DirProd_list Rs)"
-  shows "\<And>i. i < length Rs \<Longrightarrow>
-             (r1 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r2) ! i = (r1 ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (r2 ! i)" using assms
-proof (induct Rs arbitrary: r1 r2 rule: DirProd_list.induct)
-  case 1 thus ?case by simp 
-next
-  case (2 R Rs)
-  hence "\<And>i. i \<in> {(Suc 0)..<(length (R # Rs))} \<Longrightarrow>
-             (r1 \<otimes>\<^bsub>(DirProd_list (R # Rs))\<^esub> r2) ! i = (r1 ! i) \<otimes>\<^bsub>((R # Rs) ! i)\<^esub> (r2 ! i)"
-    using "2"(5) "2"(6) by auto
-  moreover have "(r1 \<otimes>\<^bsub>(DirProd_list (R # Rs))\<^esub> r2) ! 0 = (r1 ! 0) \<otimes>\<^bsub>R\<^esub> (r2 ! 0)"
-    using "2.prems"(2) "2.prems"(3) by auto
-  ultimately show ?case
-    by (metis "2.prems"(1) atLeastLessThan_iff le_0_eq not_less_eq_eq nth_Cons')  
-qed
-
-lemma DirProd_list_m_comm:
-  assumes "r1 \<in> carrier (DirProd_list Rs)" "r2 \<in> carrier (DirProd_list Rs)"
-    and "\<And>i. i < length Rs \<Longrightarrow> comm_monoid (Rs ! i)"
-  shows "r1 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r2 = r2 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r1" 
-proof (rule nth_equalityI)
-  show "length (r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r2) = length (r2 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1)"
-    by (metis DirProd_list_carrier_elts DirProd_list_m_closed Group.comm_monoid.axioms(1) assms)
-
-  fix i assume "i < length (r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r2)"
-  hence i: "i < length Rs"
-    by (metis DirProd_list_carrier_elts DirProd_list_m_closed Group.comm_monoid.axioms(1) assms)
-  have "(r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r2) ! i = (r1 ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (r2 ! i)"
-    using i DirProd_list_m_output[OF assms(1-2)] by simp
-  also have " ... = (r2 ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (r1 ! i)"
-    by (metis DirProd_list_carrier_elts DirProd_list_in_carrierE assms comm_monoid.m_comm i)
-  also have " ... = (r2 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1) ! i"
-    using i DirProd_list_m_output[OF assms(2) assms(1)] by simp
-  finally show "(r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r2) ! i = (r2 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1) ! i" .
-qed
-
-lemma DirProd_list_m_assoc:
-  assumes "r1 \<in> carrier (DirProd_list Rs)"
-      and "r2 \<in> carrier (DirProd_list Rs)"
-      and "r3 \<in> carrier (DirProd_list Rs)"
-      and "\<And>i. i < length Rs \<Longrightarrow> monoid (Rs ! i)"
-  shows "(r1 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r2) \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r3 =
-          r1 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> (r2 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r3)"
-proof (rule nth_equalityI)
-  show "length ((r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r2) \<otimes>\<^bsub>DirProd_list Rs\<^esub> r3) =
-         length (r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> (r2 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r3))"
-    by (metis DirProd_list_carrier_elts DirProd_list_m_closed assms)
-
-  fix i assume "i < length (r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r2 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r3)"
-  hence i: "i < length Rs"
-    by (metis DirProd_list_carrier_elts DirProd_list_m_closed assms)
-  have "((r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r2) \<otimes>\<^bsub>DirProd_list Rs\<^esub> r3) ! i =
-        ((r1 ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (r2 ! i)) \<otimes>\<^bsub>(Rs ! i)\<^esub> (r3 ! i)"
-    by (metis DirProd_list_m_closed DirProd_list_m_output i assms)
-  also have " ... = (r1 ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> ((r2 ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (r3 ! i))"
-    by (metis DirProd_list_carrier_elts DirProd_list_in_carrierE assms i monoid.m_assoc)
-  also have " ... = (r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> (r2 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r3)) ! i"
-    by (metis DirProd_list_m_closed DirProd_list_m_output i assms)
-  finally show "((r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r2) \<otimes>\<^bsub>DirProd_list Rs\<^esub> r3) ! i =
-                 (r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> (r2 \<otimes>\<^bsub>DirProd_list Rs\<^esub> r3))! i" .
-qed
-
-lemma DirProd_list_one:
-  "\<And>i. i < length Rs \<Longrightarrow> (\<one>\<^bsub>(DirProd_list Rs)\<^esub>) ! i =  \<one>\<^bsub>(Rs ! i)\<^esub>"
-  by (induct Rs rule: DirProd_list.induct) (simp_all add: nth_Cons')
-
-lemma DirProd_list_one_closed:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> monoid (Rs ! i)"
-  shows "\<one>\<^bsub>(DirProd_list Rs)\<^esub> \<in> carrier (DirProd_list Rs)"
-proof (rule DirProd_list_in_carrierI)
-  show eq_len: "length \<one>\<^bsub>DirProd_list Rs\<^esub> = length Rs"
-    by (induct Rs rule: DirProd_list.induct) (simp_all)
-  show "\<And>i. i < length \<one>\<^bsub>DirProd_list Rs\<^esub> \<Longrightarrow> \<one>\<^bsub>DirProd_list Rs\<^esub> ! i \<in> carrier (Rs ! i)"
-    using eq_len DirProd_list_one[where ?Rs = Rs] monoid.one_closed by (simp add: assms)
-qed
+subsection \<open>Definitions\<close>
 
-lemma DirProd_list_l_one:
-  assumes "r1 \<in> carrier (DirProd_list Rs)"
-    and "\<And>i. i < length Rs \<Longrightarrow> monoid (Rs ! i)"
-  shows "\<one>\<^bsub>(DirProd_list Rs)\<^esub> \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r1 = r1"
-proof (rule nth_equalityI)
-  show eq_len: "length (\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1) = length r1"
-    using DirProd_list_carrier_elts[of "\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1" Rs]
-      DirProd_list_carrier_elts[OF assms(1)]
-      DirProd_list_m_closed[OF DirProd_list_one_closed[OF assms(2)] assms(1)]
-    by (simp add: assms)
-  fix i assume "i < length (\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1)"
-  hence i: "i < length Rs" using DirProd_list_carrier_elts[OF assms(1)] eq_len by simp
-  hence "(\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1) ! i =
-         (\<one>\<^bsub>DirProd_list Rs\<^esub> ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (r1 ! i)"
-    using DirProd_list_m_output DirProd_list_one_closed assms by blast
-  also have " ... = \<one>\<^bsub>(Rs ! i)\<^esub> \<otimes>\<^bsub>(Rs ! i)\<^esub> (r1 ! i)"
-    by (simp add: DirProd_list_one i)
-  also have " ... = (r1 ! i)"
-    using DirProd_list_carrier_elts DirProd_list_in_carrierE i assms by fastforce
-  finally show "(\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1) ! i = (r1 ! i)" .
-qed
-
-lemma DirProd_list_r_one:
-  assumes "r1 \<in> carrier (DirProd_list Rs)"
-    and "\<And>i. i < length Rs \<Longrightarrow> monoid (Rs ! i)"
-  shows "r1 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> \<one>\<^bsub>(DirProd_list Rs)\<^esub> = r1"
-proof -
-  have "r1 \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> \<one>\<^bsub>(DirProd_list Rs)\<^esub> =
-           \<one>\<^bsub>(DirProd_list Rs)\<^esub> \<otimes>\<^bsub>(DirProd_list Rs)\<^esub> r1"
-  proof (rule nth_equalityI)
-    show " length (r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> \<one>\<^bsub>DirProd_list Rs\<^esub>) =
-           length (\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1)"
-      by (metis DirProd_list_carrier_elts DirProd_list_m_closed DirProd_list_one_closed assms)
-
-    fix i assume "i < length (r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> \<one>\<^bsub>DirProd_list Rs\<^esub>)"
-    hence i: "i < length Rs"
-      by (metis DirProd_list_carrier_elts DirProd_list_m_closed DirProd_list_one_closed assms)
-    hence "(r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> \<one>\<^bsub>DirProd_list Rs\<^esub>) ! i = (r1 ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> \<one>\<^bsub>(Rs ! i)\<^esub>"
-      by (metis DirProd_list_m_output DirProd_list_one DirProd_list_one_closed assms)
-    also have " ... =  \<one>\<^bsub>(Rs ! i)\<^esub> \<otimes>\<^bsub>(Rs ! i)\<^esub> (r1 ! i)"
-      using DirProd_list_carrier_elts DirProd_list_in_carrierE assms i by fastforce
-    also have " ... = (\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1) ! i"
-      by (metis DirProd_list_m_output DirProd_list_one DirProd_list_one_closed assms i)
-    finally show "(r1 \<otimes>\<^bsub>DirProd_list Rs\<^esub> \<one>\<^bsub>DirProd_list Rs\<^esub>) ! i =
-                  (\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> r1) ! i" .
-  qed
-  thus ?thesis using DirProd_list_l_one assms by auto
-qed
-
-lemma DirProd_list_monoid:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> monoid (Rs ! i)"
-  shows "monoid (DirProd_list Rs)"
-  unfolding monoid_def 
-proof (intro conjI allI impI)
-  show "\<one>\<^bsub>DirProd_list Rs\<^esub> \<in> carrier (DirProd_list Rs)"
-    using DirProd_list_one_closed[of Rs] assms by simp
-
-  fix x y z
-  assume x: "x \<in> carrier (DirProd_list Rs)"
-     and y: "y \<in> carrier (DirProd_list Rs)"
-     and z: "z \<in> carrier (DirProd_list Rs)"
-  show "x \<otimes>\<^bsub>DirProd_list Rs\<^esub> y \<in> carrier (DirProd_list Rs)"
-    using DirProd_list_m_closed[OF x y] assms by simp
-  show "x \<otimes>\<^bsub>DirProd_list Rs\<^esub>  y \<otimes>\<^bsub>DirProd_list Rs\<^esub> z =
-        x \<otimes>\<^bsub>DirProd_list Rs\<^esub> (y \<otimes>\<^bsub>DirProd_list Rs\<^esub> z)"
-    using DirProd_list_m_assoc[OF x y z] assms by simp
-  show "\<one>\<^bsub>DirProd_list Rs\<^esub> \<otimes>\<^bsub>DirProd_list Rs\<^esub> x = x"
-    using DirProd_list_l_one[OF x] assms by simp
-  show "x \<otimes>\<^bsub>DirProd_list Rs\<^esub> \<one>\<^bsub>DirProd_list Rs\<^esub> = x"
-    using DirProd_list_r_one[OF x] assms by simp
-qed
-
-lemma DirProd_list_comm_monoid:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> comm_monoid (Rs ! i)"
-  shows "comm_monoid (DirProd_list Rs)"
-  unfolding comm_monoid_def comm_monoid_axioms_def apply auto
-  using DirProd_list_monoid Group.comm_monoid.axioms(1) assms apply blast
-  using DirProd_list_m_comm assms by blast
-
-lemma DirProd_list_isomorphism1:
-  "(\<lambda>(hd, tl). hd # tl) \<in> iso (R \<times>\<times> (DirProd_list Rs)) (DirProd_list (R # Rs))"
-  unfolding iso_def hom_def bij_betw_def inj_on_def by auto
+abbreviation (in ring) canonical_proj :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a set \<times> 'a set"
+  where "canonical_proj I J \<equiv> (\<lambda>a. (I +> a, J +> a))"
 
-lemma DirProd_list_isomorphism2:
-  "(\<lambda>r. (hd r, tl r)) \<in> iso (DirProd_list (R # Rs)) (R \<times>\<times> (DirProd_list Rs))" (is "?\<phi> \<in> ?A")
-  unfolding iso_def hom_def bij_betw_def inj_on_def apply auto
-proof -
-  fix a b assume "a \<in> carrier R" "b \<in> carrier (DirProd_list Rs)"
-  hence "a # b \<in> {r # rs |r rs. r \<in> carrier R \<and> rs \<in> carrier (DirProd_list Rs)} \<and> ?\<phi> (a # b) = (a, b)"
-    by simp
-  thus "(a, b) \<in> ?\<phi> ` {r # rs |r rs. r \<in> carrier R \<and> rs \<in> carrier (DirProd_list Rs)}"
-    by (metis (no_types, lifting) image_iff)
-qed
-
-lemma DirProd_list_group:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> group (Rs ! i)"
-  shows "group (DirProd_list Rs)" using assms
-proof (induction Rs rule: DirProd_list.induct)
-  case 1 thus ?case
-  unfolding group_def group_axioms_def Units_def monoid_def by auto
-next
-  case (2 R Rs)
-  hence "group (DirProd_list Rs)" by force
-  moreover have "group R"
-    using "2.prems" by fastforce
-  moreover have "monoid (DirProd_list (R # Rs))"
-    using DirProd_list_monoid 2 group.is_monoid by blast
-  moreover have "R \<times>\<times> DirProd_list Rs \<cong> DirProd_list (R # Rs)"
-    unfolding is_iso_def using DirProd_list_isomorphism1 by auto
-  ultimately show ?case
-    using group.iso_imp_group[of "R \<times>\<times> (DirProd_list Rs)" "DirProd_list (R # Rs)"]
-          DirProd_group[of R "DirProd_list Rs"] by simp
-qed
-
-lemma DirProd_list_comm_group:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> comm_group (Rs ! i)"
-  shows "comm_group (DirProd_list Rs)"
-  using assms unfolding comm_group_def
-  using DirProd_list_group DirProd_list_comm_monoid by auto
-
-lemma DirProd_list_group_hom:
-  assumes "\<And>i. i \<in> {..<(length (R # Rs))} \<Longrightarrow> group ((R # Rs) ! i)"
-  shows "group_hom (R \<times>\<times> DirProd_list Rs) (DirProd_list (R # Rs)) (\<lambda>(hd, tl). hd # tl)"
-proof -
-  have "group R"
-    using assms by force
-  moreover have "group (DirProd_list Rs)"
-    using DirProd_list_group assms by fastforce
-  ultimately
-
-  have "group (R \<times>\<times> DirProd_list Rs)"
-    using DirProd_group[of R "DirProd_list Rs"] by simp
-  moreover have "group (DirProd_list (R # Rs))"
-    using DirProd_list_group assms by blast
-  moreover have "(\<lambda>(x, y). x # y) \<in> hom (R \<times>\<times> DirProd_list Rs) (DirProd_list (R # Rs))"
-    using DirProd_list_isomorphism1[of R Rs] unfolding iso_def by simp
-  ultimately show ?thesis
-    unfolding group_hom_def group_hom_axioms_def by simp
-qed
-
-lemma DirProd_list_m_inv:
-  assumes "r \<in> carrier (DirProd_list Rs)"
-      and "\<And>i. i < length Rs \<Longrightarrow> group (Rs ! i)"
-    shows "\<And>i. i < length Rs \<Longrightarrow> (inv\<^bsub>(DirProd_list Rs)\<^esub> r) ! i = inv\<^bsub>(Rs ! i)\<^esub> (r ! i)"
-  using assms
-proof (induct Rs arbitrary: r rule: DirProd_list.induct)
-  case 1
-  have "group (DirProd_list [])"
-    unfolding group_def group_axioms_def Units_def monoid_def by auto
-  thus ?case  using "1.prems"(1) group.inv_equality by fastforce    
-next
-  case (2 R Rs)
-  then obtain r' rs' where r': "r' \<in> carrier R" and rs': "rs' \<in> carrier (DirProd_list Rs)"
-                       and r: "r = r' # rs'" by auto
-  hence "(r', rs') \<in> carrier (R \<times>\<times> DirProd_list Rs)" by simp
-  moreover have "group_hom (R \<times>\<times> DirProd_list Rs) (DirProd_list (R # Rs)) (\<lambda>(hd, tl). hd # tl)"
-    using DirProd_list_group_hom[of R Rs] 2 by auto
-  moreover have "inv\<^bsub>(R \<times>\<times> DirProd_list Rs)\<^esub> (r', rs') = (inv\<^bsub>R\<^esub> r', inv\<^bsub>(DirProd_list Rs)\<^esub> rs')"
-    using inv_DirProd[of R "DirProd_list Rs" r' rs'] "2.prems"(3) DirProd_list_group r' rs' by force
-  ultimately have "inv\<^bsub>(DirProd_list (R # Rs))\<^esub> r = (inv\<^bsub>R\<^esub> r') # (inv\<^bsub>(DirProd_list Rs)\<^esub> rs')"
-    using group_hom.hom_inv[of "R \<times>\<times> DirProd_list Rs" "DirProd_list (R # Rs)"
-                               "\<lambda>(hd, tl). hd # tl" "(r', rs')"] r by simp
-  thus ?case
-    using 2 by simp (metis (no_types, lifting) less_Suc_eq_0_disj list.sel(3) nth_Cons_0 nth_Cons_Suc r)
-qed
+definition (in ring) canonical_proj_ext :: "(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> ('a set) list"
+  where "canonical_proj_ext I n = (\<lambda>a. map (\<lambda>i. (I i) +> a) [0..< Suc n])"
 
 
-subsection \<open>Direct Product for of a List of Rings\<close>
-
-text \<open>In order to state a more general version of the Chinese Remainder Theorem, we need a new
-      structure: the direct product of a variable number of rings. The construction of this
-      structure as well as its algebraic properties are the subject of this subsection and follow
-      the similar study that has already been done for monoids in the previous subsection.\<close>
+subsection \<open>Chinese Remainder Simple\<close>
 
-fun RDirProd_list :: "('a ring) list \<Rightarrow> ('a list) ring"
-  where "RDirProd_list Rs =
-           monoid.extend (monoid.truncate (DirProd_list Rs))
-                         \<lparr> zero = one (DirProd_list (map add_monoid Rs)),
-                           add = mult (DirProd_list (map add_monoid Rs)) \<rparr>"
-
-lemma RDirProd_list_add_monoid:
-  "add_monoid (RDirProd_list Rs) = DirProd_list (map add_monoid Rs)"
-proof -
-  have "carrier (RDirProd_list Rs) = carrier (DirProd_list (map add_monoid Rs))"
-    by (induct Rs rule: DirProd_list.induct) (simp_all add: monoid.defs)
-  thus ?thesis by (simp add: monoid.defs)
-qed
-
-lemma RDirProd_list_mult_monoid:
-  "monoid.truncate (RDirProd_list Rs) = monoid.truncate (DirProd_list Rs)"
-  by (simp add: monoid.defs)
+lemma (in ring) canonical_proj_is_surj:
+  assumes "ideal I R" "ideal J R" and "I <+> J = carrier R"
+  shows "(canonical_proj I J) ` carrier R = carrier (RDirProd (R Quot I) (R Quot J))"
+  unfolding RDirProd_def DirProd_def FactRing_def A_RCOSETS_def'
+proof (auto simp add: monoid.defs)
+  { fix I i assume "ideal I R" "i \<in> I" hence "I +> i = \<zero>\<^bsub>R Quot I\<^esub>"
+      using a_rcos_zero by (simp add: FactRing_def)
+  } note aux_lemma1 = this
 
-lemma RDirProd_list_monoid:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> monoid (Rs ! i)"
-  shows "monoid (RDirProd_list Rs)"
-proof -
-  have "monoid (DirProd_list Rs)"
-    using DirProd_list_monoid assms by blast
-  hence "monoid (monoid.truncate (DirProd_list Rs))"
-    unfolding monoid_def by (auto intro: monoid.intro simp add: monoid.defs)
-  hence "monoid (monoid.truncate (RDirProd_list Rs))"
-    by (simp add: monoid.defs)
-  thus ?thesis
-    unfolding monoid_def by (auto intro: monoid.intro simp add: monoid.defs)
-qed
+  { fix I i j assume A: "ideal I R" "i \<in> I" "j \<in> carrier R" "i \<oplus> j = \<one>"
+    have "(I +> i) \<oplus>\<^bsub>R Quot I\<^esub> (I +> j) = I +> \<one>"
+      using ring_hom_memE(3)[OF ideal.rcos_ring_hom ideal.Icarr[OF _ A(2)] A(3)] A(1,4) by simp
+    moreover have "I +> i = I"
+      using abelian_subgroupI3[OF ideal.axioms(1) is_abelian_group]
+      by (simp add: A(1-2) abelian_subgroup.a_rcos_const)
+    moreover have "I +> j \<in> carrier (R Quot I)" and "I = \<zero>\<^bsub>R Quot I\<^esub>" and "I +> \<one> = \<one>\<^bsub>R Quot I\<^esub>"
+      by (auto simp add: FactRing_def A_RCOSETS_def' A(3))
+    ultimately have "I +> j = \<one>\<^bsub>R Quot I\<^esub>"
+      using ring.ring_simprules(8)[OF ideal.quotient_is_ring[OF A(1)]] by simp
+  } note aux_lemma2 = this
 
-lemma RDirProd_list_comm_monoid:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> comm_monoid (Rs ! i)"
-  shows "comm_monoid (RDirProd_list Rs)"
-proof -
-  have "comm_monoid (DirProd_list Rs)"
-    using DirProd_list_comm_monoid assms by blast
-  hence "comm_monoid (monoid.truncate (DirProd_list Rs))"
-    unfolding comm_monoid_def monoid_def comm_monoid_axioms_def
-    by (auto simp add: monoid.defs)
-  hence "comm_monoid (monoid.truncate (RDirProd_list Rs))"
-    by (simp add: monoid.defs)
-  thus ?thesis
-    unfolding comm_monoid_def monoid_def comm_monoid_axioms_def
-    by (auto simp add: monoid.defs)
-qed
-
-lemma RDirProd_list_abelian_monoid:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> abelian_monoid (Rs ! i)"
-  shows "abelian_monoid (RDirProd_list Rs)"
-proof -
-  have "\<And>i. i < length Rs \<Longrightarrow> comm_monoid ((map add_monoid Rs) ! i)"
-    using assms unfolding abelian_monoid_def by simp
-  hence "comm_monoid (DirProd_list (map add_monoid Rs))"
-    by (metis (no_types, lifting) DirProd_list_comm_monoid length_map)
-  thus ?thesis
-    unfolding abelian_monoid_def by (metis RDirProd_list_add_monoid) 
-qed
+  interpret I: ring "R Quot I" + J: ring "R Quot J"
+    using assms(1-2)[THEN ideal.quotient_is_ring] by auto
 
-lemma RDirProd_list_abelian_group:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> abelian_group (Rs ! i)"
-  shows "abelian_group (RDirProd_list Rs)"
-proof -
-  have "\<And>i. i < length Rs \<Longrightarrow> comm_group ((map add_monoid Rs) ! i)"
-    using assms unfolding abelian_group_def abelian_group_axioms_def by simp
-  hence "comm_group (DirProd_list (map add_monoid Rs))"
-    by (metis (no_types, lifting) DirProd_list_comm_group length_map)
-  thus ?thesis
-    unfolding abelian_group_def abelian_group_axioms_def
-    by (metis RDirProd_list_abelian_monoid RDirProd_list_add_monoid abelian_group_def assms)
-qed
-
-lemma RDirProd_list_carrier_elts:
-  assumes "rs \<in> carrier (RDirProd_list Rs)"
-  shows "length rs = length Rs"
-  using assms by (simp add: DirProd_list_carrier_elts monoid.defs)
+  fix a b assume a: "a \<in> carrier R" and b: "b \<in> carrier R"
+  have "\<one> \<in> I <+> J"
+    using assms(3) by blast
+  then obtain i j where i: "i \<in> carrier R" "i \<in> I" and j: "j \<in> carrier R" "j \<in> J" and ij: "i \<oplus> j = \<one>"
+    using assms(1-2)[THEN ideal.Icarr] unfolding set_add_def' by auto
+  hence rcos_j: "I +> j = \<one>\<^bsub>R Quot I\<^esub>" and rcos_i: "J +> i = \<one>\<^bsub>R Quot J\<^esub>"
+    using assms(1-2)[THEN aux_lemma2] a_comm by simp+
 
-lemma RDirProd_list_in_carrierE:
-  assumes "rs \<in> carrier (RDirProd_list Rs)"
-  shows "\<And>i. i < length rs \<Longrightarrow> rs ! i \<in> carrier (Rs ! i)"
-  using assms by (simp add: DirProd_list_in_carrierE monoid.defs)
-
-lemma RDirProd_list_in_carrierI:
-  assumes "\<And>i. i < length rs \<Longrightarrow> rs ! i \<in> carrier (Rs ! i)"
-      and "length rs = length Rs"
-    shows "rs \<in> carrier (RDirProd_list Rs)"
-  using DirProd_list_in_carrierI assms by (simp add: monoid.defs, blast)
-
-lemma RDirProd_list_one:
-  "\<And>i. i < length Rs \<Longrightarrow> (\<one>\<^bsub>(RDirProd_list Rs)\<^esub>) ! i =  \<one>\<^bsub>(Rs ! i)\<^esub>"
-  by (simp add: DirProd_list_one monoid.defs)
-
-lemma RDirProd_list_zero:
-  "\<And>i. i < length Rs \<Longrightarrow> (\<zero>\<^bsub>(RDirProd_list Rs)\<^esub>) ! i =  \<zero>\<^bsub>(Rs ! i)\<^esub>"
-  by (induct Rs rule: DirProd_list.induct) (simp_all add: monoid.defs nth_Cons')
+  define s where "s = (a \<otimes> j) \<oplus> (b \<otimes> i)"
+  hence "s \<in> carrier R"
+    using a b i j by simp
 
-lemma RDirProd_list_m_output:
-  assumes "r1 \<in> carrier (RDirProd_list Rs)" "r2 \<in> carrier (RDirProd_list Rs)"
-  shows "\<And>i. i < length Rs \<Longrightarrow>
-             (r1 \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> r2) ! i = (r1 ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (r2 ! i)"
-  using assms by (simp add: DirProd_list_m_output monoid.defs)
+  have "I +> s = ((I +> a) \<otimes>\<^bsub>R Quot I\<^esub> (I +> j)) \<oplus>\<^bsub>R Quot I\<^esub> (I +> (b \<otimes> i))"
+    using ring_hom_memE(2-3)[OF ideal.rcos_ring_hom[OF assms(1)]]
+    by (simp add: a b i(1) j(1) s_def)
+  moreover have "I +> a \<in> carrier (R Quot I)"
+    by (auto simp add: FactRing_def A_RCOSETS_def' a)
+  ultimately have "I +> s = I +> a"
+    unfolding rcos_j aux_lemma1[OF assms(1) ideal.I_l_closed[OF assms(1) i(2) b]] by simp
 
-lemma RDirProd_list_a_output:
-  fixes i
-  assumes "r1 \<in> carrier (RDirProd_list Rs)" "r2 \<in> carrier (RDirProd_list Rs)" "i < length Rs"
-  shows "(r1 \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> r2) ! i = (r1 ! i) \<oplus>\<^bsub>(Rs ! i)\<^esub> (r2 ! i)"
-  using RDirProd_list_add_monoid[of Rs] monoid.defs(3)
-proof -
-  have "(\<otimes>\<^bsub>DirProd_list (map add_monoid Rs)\<^esub>) = (\<oplus>\<^bsub>RDirProd_list Rs\<^esub>)"
-    by (metis \<open>add_monoid (RDirProd_list Rs) = DirProd_list (map add_monoid Rs)\<close> monoid.select_convs(1))
-  moreover have "r1 \<in> carrier (DirProd_list (map add_monoid Rs))"
-    by (metis \<open>add_monoid (RDirProd_list Rs) = DirProd_list (map add_monoid Rs)\<close> assms(1) partial_object.select_convs(1))
-  moreover have "r2 \<in> carrier (DirProd_list (map add_monoid Rs))"
-    by (metis \<open>add_monoid (RDirProd_list Rs) = DirProd_list (map add_monoid Rs)\<close> assms(2) partial_object.select_convs(1))
-  ultimately show ?thesis
-    by (simp add: DirProd_list_m_output assms(3))
-qed
+  have "J +> s = (J +> (a \<otimes> j)) \<oplus>\<^bsub>R Quot J\<^esub> ((J +> b) \<otimes>\<^bsub>R Quot J\<^esub> (J +> i))"
+    using ring_hom_memE(2-3)[OF ideal.rcos_ring_hom[OF assms(2)]]
+    by (simp add: a b i(1) j(1) s_def)
+  moreover have "J +> b \<in> carrier (R Quot J)"
+    by (auto simp add: FactRing_def A_RCOSETS_def' b)
+  ultimately have "J +> s = J +> b"
+    unfolding rcos_i aux_lemma1[OF assms(2) ideal.I_l_closed[OF assms(2) j(2) a]] by simp
 
-lemma RDirProd_list_a_inv:
-  fixes i
-  assumes "r \<in> carrier (RDirProd_list Rs)"
-    and "\<And>i. i < length Rs \<Longrightarrow> abelian_group (Rs ! i)"
-    and i: "i < length Rs"
-  shows "(\<ominus>\<^bsub>(RDirProd_list Rs)\<^esub> r) ! i = \<ominus>\<^bsub>(Rs ! i)\<^esub> (r ! i)"
-proof -
-  have "m_inv (DirProd_list (map add_monoid Rs)) = a_inv (RDirProd_list Rs)"
-    by (metis RDirProd_list_add_monoid a_inv_def)
-  moreover have "r \<in> carrier (DirProd_list (map add_monoid Rs))"
-    by (metis RDirProd_list_add_monoid assms(1) partial_object.select_convs(1))
-  moreover have "a_inv (Rs ! i) = m_inv (map add_monoid Rs ! i)"
-    by (simp add: a_inv_def i)
-  ultimately show ?thesis
-    by (metis (no_types, lifting) DirProd_list_carrier_elts DirProd_list_m_inv RDirProd_list_carrier_elts
-        abelian_group.a_group assms list_update_same_conv map_update)  
+  from \<open>I +> s = I +> a\<close> and \<open>J +> s = J +> b\<close> and \<open>s \<in> carrier R\<close>
+  show "(I +> a, J +> b) \<in> (canonical_proj I J) ` carrier R" by blast
 qed
 
-lemma RDirProd_list_l_distr:
-  assumes "x \<in> carrier (RDirProd_list Rs)"
-      and "y \<in> carrier (RDirProd_list Rs)"
-      and "z \<in> carrier (RDirProd_list Rs)"
-      and "\<And>i. i < length Rs \<Longrightarrow> ring (Rs ! i)"
-    shows "(x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y) \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z =
-           (x \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (y \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z)"
-proof -
-  have "length ((x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y) \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) =
-        length ((x \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (y \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z))"
-    by (metis RDirProd_list_abelian_group RDirProd_list_carrier_elts RDirProd_list_monoid
-        abelian_groupE(1) assms monoid.m_closed ring.is_abelian_group ring.is_monoid)
-
-  moreover
-  have "\<And>i. i < length Rs \<Longrightarrow>
-            ((x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y) \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) ! i =
-            ((x \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (y \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z)) ! i"
-  proof -
-    fix i assume i: "i < length Rs"
-    hence "((x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y) \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) ! i =
-           ((x ! i) \<oplus>\<^bsub>(Rs ! i)\<^esub> (y ! i)) \<otimes>\<^bsub>(Rs ! i)\<^esub> (z ! i)"
-      using RDirProd_list_m_output RDirProd_list_a_output assms
-      by (metis RDirProd_list_abelian_group abelian_groupE(1) lessThan_iff ring.is_abelian_group)
-    also have " ... = ((x ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (z ! i)) \<oplus>\<^bsub>(Rs ! i)\<^esub> ((y ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (z ! i))"
-      by (metis RDirProd_list_carrier_elts RDirProd_list_in_carrierE
-          i assms lessThan_iff ring.ring_simprules(13))
-    also
-    have " ... = ((x \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (y \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z)) ! i"
-      using RDirProd_list_m_output RDirProd_list_a_output assms
-      by (metis RDirProd_list_monoid i lessThan_iff monoid.m_closed ring.is_monoid)
-    finally
-    show "((x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y) \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) ! i =
-          ((x \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (y \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z)) ! i" .
-  qed
-
-  moreover have "length ((x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y) \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> z) = length Rs"
-    by (meson RDirProd_list_abelian_group RDirProd_list_carrier_elts RDirProd_list_monoid
-        abelian_groupE(1) assms monoid.m_closed ring.is_abelian_group ring.is_monoid)
-
-  ultimately show ?thesis by (simp add: nth_equalityI) 
-qed
-
-lemma RDirProd_list_r_distr:
-  assumes "x \<in> carrier (RDirProd_list Rs)"
-      and "y \<in> carrier (RDirProd_list Rs)"
-      and "z \<in> carrier (RDirProd_list Rs)"
-      and "\<And>i. i < length Rs \<Longrightarrow> ring (Rs ! i)"
-    shows "z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> (x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y) =
-          (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> x) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> y)"
-proof -
-  have "length (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> (x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y)) =
-        length ((z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> x) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> y))"
-    by (metis RDirProd_list_abelian_group RDirProd_list_carrier_elts RDirProd_list_monoid
-        abelian_groupE(1) assms monoid.m_closed ring.is_abelian_group ring.is_monoid)
-
-  moreover
-  have "\<And>i. i < length Rs \<Longrightarrow>
-            (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> (x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y)) ! i =
-           ((z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> x) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> y)) ! i"
-  proof -
-    fix i assume i: "i < length Rs"
-    hence "(z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> (x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y)) ! i =
-           (z ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> ((x ! i) \<oplus>\<^bsub>(Rs ! i)\<^esub> (y ! i))"
-      using RDirProd_list_m_output RDirProd_list_a_output assms
-      by (metis RDirProd_list_abelian_group abelian_groupE(1) lessThan_iff ring.is_abelian_group)
-    also have " ... = ((z ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (x ! i)) \<oplus>\<^bsub>(Rs ! i)\<^esub> ((z ! i) \<otimes>\<^bsub>(Rs ! i)\<^esub> (y ! i))"
-      by (metis RDirProd_list_carrier_elts RDirProd_list_in_carrierE
-          assms i lessThan_iff ring.ring_simprules(23))
-    also
-    have " ... = ((z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> x) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> y)) ! i"
-      using RDirProd_list_m_output RDirProd_list_a_output assms
-      by (metis RDirProd_list_monoid i lessThan_iff monoid.m_closed ring.is_monoid)
-    finally
-    show "(z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> (x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y)) ! i =
-         ((z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> x) \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> y)) ! i" .
-  qed
-
-  moreover have "length (z \<otimes>\<^bsub>(RDirProd_list Rs)\<^esub> (x \<oplus>\<^bsub>(RDirProd_list Rs)\<^esub> y)) = length Rs"
-    by (meson RDirProd_list_abelian_group RDirProd_list_carrier_elts RDirProd_list_monoid
-        abelian_groupE(1) assms monoid.m_closed ring.is_abelian_group ring.is_monoid)
-
-  ultimately show ?thesis by (simp add: nth_equalityI)
-qed
-
-theorem RDirProd_list_ring:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> ring (Rs ! i)"
-  shows "ring (RDirProd_list Rs)"
-  using assms unfolding ring_def ring_axioms_def using assms 
-  by (meson RDirProd_list_abelian_group RDirProd_list_l_distr
-            RDirProd_list_monoid RDirProd_list_r_distr)
-
-theorem RDirProd_list_cring:
-  assumes "\<And>i. i < length Rs \<Longrightarrow> cring (Rs ! i)"
-  shows "cring (RDirProd_list Rs)"
-  by (meson RDirProd_list_comm_monoid RDirProd_list_ring assms cring_def)
-
-corollary (in cring) RDirProd_list_of_quot_is_cring:
-  assumes "\<And>i. i < n \<Longrightarrow> ideal (I i) R"
-    shows "cring (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< n]))"
-      (is "cring (RDirProd_list ?Rs)")
-proof -
-  have "\<And>i. i \<in> {..<(length ?Rs)} \<Longrightarrow> cring (?Rs ! i)"
-    by (simp add: assms ideal.quotient_is_cring is_cring)
-  thus ?thesis
-    using RDirProd_list_cring by blast
-qed
-
-lemma length_RDirProd_list_0: 
-  assumes "\<And>i. i < n \<Longrightarrow> cring (F i)" 
-  shows "length (\<zero>\<^bsub>(RDirProd_list (map F [0..< n]))\<^esub>) = n"
-  by (metis (no_types, lifting) add_cancel_right_left RDirProd_list_carrier_elts RDirProd_list_cring cring.cring_simprules(2) diff_zero length_map length_upt nth_map_upt assms)
-
-lemma RDirProd_list_isomorphism1:
-  "(\<lambda>(hd, tl). hd # tl) \<in> ring_iso (RDirProd R (RDirProd_list Rs)) (RDirProd_list (R # Rs))"
-  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def RDirProd_def
-  by (auto simp add: monoid.defs)
-
-lemma RDirProd_list_isomorphism1':
-  "(RDirProd R (RDirProd_list Rs)) \<simeq> (RDirProd_list (R # Rs))"
-  unfolding is_ring_iso_def using RDirProd_list_isomorphism1 by blast 
-
-lemma RDirProd_list_isomorphism2:
-  "(\<lambda>r. (hd r, tl r)) \<in> ring_iso (RDirProd_list (R # Rs)) (RDirProd R (RDirProd_list Rs))"
-  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def RDirProd_def
-proof (auto simp add: monoid.defs)
-  let ?\<phi> = "\<lambda>r. (hd r, tl r)"
-  fix a b assume "a \<in> carrier R" "b \<in> carrier (DirProd_list Rs)"
-  hence "a # b \<in> {r # rs |r rs. r \<in> carrier R \<and> rs \<in> carrier (DirProd_list Rs)} \<and> ?\<phi> (a # b) = (a, b)"
-    by simp
-  thus "(a, b) \<in> ?\<phi> ` {r # rs |r rs. r \<in> carrier R \<and> rs \<in> carrier (DirProd_list Rs)}"
-    by (metis (no_types, lifting) image_iff)
-qed
-
-lemma RDirProd_list_isomorphism3:
-  "(\<lambda>(r, l). r @ [l]) \<in> ring_iso (RDirProd (RDirProd_list Rs) S) (RDirProd_list (Rs @ [S]))"
-proof (induction Rs rule: DirProd_list.induct)
-  case 1 thus ?case
-    unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def RDirProd_def
-    by (auto simp add: monoid.defs image_iff)
+lemma (in ring) canonical_proj_ker:
+  assumes "ideal I R" and "ideal J R"
+  shows "a_kernel R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J) = I \<inter> J"
+proof
+  show "a_kernel R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J) \<subseteq> I \<inter> J"
+    unfolding FactRing_def RDirProd_def DirProd_def a_kernel_def'
+    by (auto simp add: assms[THEN ideal.rcos_const_imp_mem] monoid.defs)
 next
-  case (2 R Rs)
-
-  { fix r1 r2 assume A0: "r1 \<in> carrier (RDirProd_list (R # Rs))"
-                 and A1: "r2 \<in> carrier (RDirProd_list (R # Rs))"
-    have "length r1 \<ge> 1"
-     and "length r2 \<ge> 1"
-     and "length (r1 \<otimes>\<^bsub>(RDirProd_list (R # Rs))\<^esub> r2) \<ge> 1"
-     and "length (r1 \<oplus>\<^bsub>(RDirProd_list (R # Rs))\<^esub> r2) \<ge> 1"
-     and "length (\<one>\<^bsub>(RDirProd_list (R # Rs))\<^esub>) \<ge> 1"
-    proof -
-      show len_r1: "length r1 \<ge> 1"
-       and len_r2: "length r2 \<ge> 1"
-        by (metis RDirProd_list_carrier_elts A0 A1 length_Cons less_one nat.simps(3) not_less)+
-      show "length (r1 \<otimes>\<^bsub>(RDirProd_list (R # Rs))\<^esub> r2) \<ge> 1"
-       and "length (r1 \<oplus>\<^bsub>(RDirProd_list (R # Rs))\<^esub> r2) \<ge> 1"
-       and "length (\<one>\<^bsub>(RDirProd_list (R # Rs))\<^esub>) \<ge> 1"
-        using len_r1 len_r2 by (simp_all add: monoid.defs)
-    qed } note aux_lemma = this
-
-  moreover
-  have "(\<lambda>(r, s). (hd r, (tl r, s))) \<in>
-          ring_iso (RDirProd (RDirProd_list (R # Rs)) S)
-                   (RDirProd R (RDirProd (RDirProd_list Rs) S))"
-    using ring_iso_set_trans[OF RDirProd_isomorphism4[OF RDirProd_list_isomorphism2[of R Rs],of S]
-                                RDirProd_isomorphism3[of R "RDirProd_list Rs" S]]
-    by (simp add: case_prod_beta' comp_def)
-
-  moreover
-  have "(\<lambda>(hd, (tl, s)). hd # (tl @ [s])) \<in>
-          ring_iso (RDirProd R (RDirProd (RDirProd_list Rs) S))
-                   (RDirProd_list (R # (Rs @ [S])))"
-    using ring_iso_set_trans[OF RDirProd_isomorphism5[OF 2(1), of R]
-                                RDirProd_list_isomorphism1[of R "Rs @ [S]"]]
-    by (simp add: case_prod_beta' comp_def)
-
-  moreover
-  have "(\<lambda>(r, s). (hd r) # ((tl r) @ [s])) \<in>
-          ring_iso (RDirProd (RDirProd_list (R # Rs)) S) (RDirProd_list (R # (Rs @ [S])))"
-    using ring_iso_set_trans[OF calculation(6-7)] by (simp add: case_prod_beta' comp_def)
-  hence iso: "(\<lambda>(r, s). (hd r # tl r) @ [s]) \<in>
-           ring_iso (RDirProd (RDirProd_list (R # Rs)) S) (RDirProd_list ((R # Rs) @ [S]))" by simp
-  
-  show ?case
-  proof (rule ring_iso_morphic_prop[OF iso, of "\<lambda>r. length (fst r) \<ge> 1" "\<lambda>(r, s). r @ [s]"])
-    show "\<And>r. 1 \<le> length (fst r) \<Longrightarrow>
-              (case r of (r, s) \<Rightarrow> (hd r # tl r) @ [s]) = (case r of (r, s) \<Rightarrow> r @ [s])"
-      by (simp add: Suc_le_eq case_prod_beta')
-    show "morphic_prop (RDirProd (RDirProd_list (R # Rs)) S) (\<lambda>r. 1 \<le> length (fst r))"
-      unfolding RDirProd_def by (rule morphic_propI) (auto simp add: monoid.defs aux_lemma)
+  show "I \<inter> J \<subseteq> a_kernel R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J)"
+  proof
+    fix s assume s: "s \<in> I \<inter> J" then have "I +> s = I" and "J +> s = J"
+      using abelian_subgroupI3[OF ideal.axioms(1) is_abelian_group]
+      by (simp add: abelian_subgroup.a_rcos_const assms)+
+    thus "s \<in> a_kernel R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J)"
+      unfolding FactRing_def RDirProd_def DirProd_def a_kernel_def'
+      using ideal.Icarr[OF assms(1)] s by (simp add: monoid.defs)
   qed
 qed
 
-
-subsection \<open>Second Generalization - The Extended Canonical Projection is a Homomorphism and
-                                    Description of its Kernel\<close>
-
-theorem (in cring) canonical_proj_ext_is_hom:
-  fixes n::nat
-  assumes "\<And>i. i < n \<Longrightarrow> ideal (I i) R"
-      and "\<And>i j. \<lbrakk> i < n; j < n; i \<noteq> j \<rbrakk> \<Longrightarrow> I i <+> I j = carrier R"
-    shows "(\<lambda>a. (map (\<lambda>i. (I i) +> a) [0..< n])) \<in>
-            ring_hom R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< n]))" (is "?\<phi> \<in> ?ring_hom")
-proof (rule ring_hom_memI)
-  { fix x assume x: "x \<in> carrier R"
-    have "?\<phi> x \<in> carrier (RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n]))"
-    apply (rule RDirProd_list_in_carrierI)
-    by (simp_all add: FactRing_def a_rcosetsI additive_subgroup.a_subset assms(1) ideal.axioms(1) x) }
-  note aux_lemma = this
+lemma (in ring) canonical_proj_is_hom:
+  assumes "ideal I R" and "ideal J R"
+  shows "(canonical_proj I J) \<in> ring_hom R (RDirProd (R Quot I) (R Quot J))"
+  unfolding RDirProd_def DirProd_def FactRing_def A_RCOSETS_def'
+  by (auto intro!: ring_hom_memI
+         simp add: assms[THEN ideal.rcoset_mult_add]
+                   assms[THEN ideal.a_rcos_sum] monoid.defs)
 
-  fix x y assume x: "x \<in> carrier R" and y: "y \<in> carrier R"
-  show x': "?\<phi> x \<in> carrier (RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n]))"
-    using aux_lemma[OF x] .
-  hence x'': "?\<phi> x \<in> carrier (DirProd_list (map (\<lambda>i. R Quot I i) [0..<n]))"
-    by (simp add: monoid.defs)
+lemma (in ring) canonical_proj_ring_hom:
+  assumes "ideal I R" and "ideal J R"
+  shows "ring_hom_ring R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J)"
+  using ring_hom_ring.intro[OF ring_axioms RDirProd_ring[OF assms[THEN ideal.quotient_is_ring]]]
+  by (simp add: ring_hom_ring_axioms_def canonical_proj_is_hom[OF assms])
 
-  have y': "?\<phi> y \<in> carrier (RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n]))"
-    using aux_lemma[OF y] .
-  hence y'': "map (\<lambda>i. I i +> y) [0..<n] \<in> carrier (DirProd_list (map (\<lambda>i. R Quot I i) [0..<n]))"
-    by (simp add: monoid.defs)
+theorem (in ring) chinese_remainder_simple:
+  assumes "ideal I R" "ideal J R" and "I <+> J = carrier R"
+  shows "R Quot (I \<inter> J) \<simeq> RDirProd (R Quot I) (R Quot J)"
+  using ring_hom_ring.FactRing_iso[OF canonical_proj_ring_hom canonical_proj_is_surj]
+  by (simp add: canonical_proj_ker assms)
 
-  show "?\<phi> (x \<otimes> y) = ?\<phi> x \<otimes>\<^bsub>RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n])\<^esub> ?\<phi> y"
-    apply (rule nth_equalityI) 
-    apply (metis RDirProd_list_carrier_elts RDirProd_list_of_quot_is_cring assms(1)
-                 cring.cring_simprules(5) length_map x' y')
-    apply (simp add: monoid.defs)
-    using DirProd_list_m_output [of "?\<phi> x" "(map (\<lambda>i. R Quot I i) [0..<n])" "?\<phi> y"] x'' y''
-    by (simp add: x'' y'' FactRing_def  assms(1) ideal.rcoset_mult_add x y)
+
+subsection \<open>Chinese Remainder Generalized\<close>
+
+lemma (in ring) canonical_proj_ext_zero [simp]: "(canonical_proj_ext I 0) = (\<lambda>a. [ (I 0) +> a ])"
+  unfolding canonical_proj_ext_def by simp
 
-  show "?\<phi> (x \<oplus> y) = ?\<phi> x \<oplus>\<^bsub>RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n])\<^esub> ?\<phi> y"
-  proof -
-    have "length (?\<phi> (x \<oplus> y)) =
-          length ((?\<phi> x) \<oplus>\<^bsub>RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n])\<^esub> (?\<phi> y))"
-      by (metis RDirProd_list_carrier_elts RDirProd_list_of_quot_is_cring assms(1)
-          cring.cring_simprules(1) length_map x' y')
+lemma (in ring) canonical_proj_ext_tl:
+  "(\<lambda>a. canonical_proj_ext I (Suc n) a) = (\<lambda>a. ((I 0) +> a) # (canonical_proj_ext (\<lambda>i. I (Suc i)) n a))"
+  unfolding canonical_proj_ext_def by (induct n) (auto, metis (lifting) append.assoc append_Cons append_Nil)
+
+lemma (in ring) canonical_proj_ext_is_hom:
+  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R"
+  shows "(canonical_proj_ext I n) \<in> ring_hom R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))"
+  using assms
+proof (induct n arbitrary: I)
+  case 0 thus ?case
+    using RDirProd_list_hom2[OF ideal.rcos_ring_hom[of _ R]] by (simp add: canonical_proj_ext_def)
+next
+  let ?DirProd = "\<lambda>I n. RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..<Suc n])"
+  let ?proj = "\<lambda>I n. canonical_proj_ext I n"
 
-    moreover
-    have "\<And>j. j < n \<Longrightarrow>
-              (?\<phi> (x \<oplus> y)) ! j = ((?\<phi> x) \<oplus>\<^bsub>RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n])\<^esub> (?\<phi> y)) ! j"
-    proof -
-      fix j assume j: "j < n"
-      have "(?\<phi> (x \<oplus> y)) ! j = I j +> x \<oplus> y" using j by simp
-      also have " ... = (I j +> x) \<oplus>\<^bsub>(R Quot I j)\<^esub> (I j +> y)"
-        by (simp add: FactRing_def abelian_subgroup.a_rcos_sum abelian_subgroupI3
-            assms(1) ideal.axioms(1) is_abelian_group j x y)
-      also have " ... = ((?\<phi> x) \<oplus>\<^bsub>RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n])\<^esub> (?\<phi> y)) ! j"
-      proof -
-        have "R Quot I j = map (\<lambda>n. R Quot I n) [0..<n] ! j"
-             "I j +> x = I ([0..<n] ! j) +> x" 
-             "I j +> y = I ([0..<n] ! j) +> y"
-          by (simp_all add: j)
-        moreover have "\<And>n ns f. n < length ns \<Longrightarrow> map f ns ! n = (f (ns ! n::nat)::'a set)"
-          by simp
-        moreover have "\<And>B ps C n. \<lbrakk>B \<in> carrier (RDirProd_list ps); C \<in> carrier (RDirProd_list ps); n < length ps\<rbrakk> 
-                     \<Longrightarrow> (B \<oplus>\<^bsub>RDirProd_list ps\<^esub> C) ! n = (B ! n::'a set) \<oplus>\<^bsub>ps ! n\<^esub> C ! n"
-          by (meson RDirProd_list_a_output)
-        ultimately show ?thesis
-          by (metis (mono_tags, lifting) diff_zero j length_map length_upt x' y') 
-      qed
-      finally show "(?\<phi> (x \<oplus> y)) ! j =
-                    ((?\<phi> x) \<oplus>\<^bsub>RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n])\<^esub> (?\<phi> y)) ! j" .
-    qed
-    ultimately show "?\<phi> (x \<oplus> y) = ?\<phi> x \<oplus>\<^bsub>RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n])\<^esub> ?\<phi> y"
-      by (simp add: list_eq_iff_nth_eq)
-  qed
-next
-  show "(?\<phi> \<one>) = \<one>\<^bsub>RDirProd_list (map (\<lambda>i. R Quot I i) [0..<n])\<^esub>"
-    apply (rule nth_equalityI)
-    apply (metis RDirProd_list_carrier_elts cring.cring_simprules(6)
-                 RDirProd_list_of_quot_is_cring assms(1) length_map)
-    using DirProd_list_one[where ?Rs = "map (\<lambda>i. R Quot I i) [0..<n]"]
-    by (simp add: FactRing_def monoid.defs)
+  case (Suc n)
+  hence I: "ideal (I 0) R" by simp
+  have hom: "(?proj (\<lambda>i. I (Suc i)) n) \<in> ring_hom R (?DirProd (\<lambda>i. I (Suc i)) n)"
+    using Suc(1)[of "\<lambda>i. I (Suc i)"] Suc(2) by simp
+  have [simp]:
+    "(\<lambda>(a, as). a # as) \<circ> ((\<lambda>(r, s). (I 0 +> r, ?proj (\<lambda>i. I (Suc i)) n s)) \<circ> (\<lambda>a. (a, a))) = ?proj I (Suc n)"
+    unfolding canonical_proj_ext_tl by auto
+  moreover have
+    "(R Quot I 0) # (map (\<lambda>i. R Quot I (Suc i)) [0..< Suc n]) = map (\<lambda>i. R Quot (I i)) [0..< Suc (Suc n)]"
+    by (induct n) (auto)
+  moreover show ?case
+    using ring_hom_trans[OF ring_hom_trans[OF RDirProd_hom1
+          RDirProd_hom3[OF ideal.rcos_ring_hom[OF I] hom]] RDirProd_list_hom1]
+    unfolding calculation(2) by simp
 qed
 
-theorem (in cring) canonical_proj_ext_kernel:
-  fixes n::nat
+lemma (in ring) RDirProd_Quot_list_is_ring:
+  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R" shows "ring (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))"
+proof -
+  have ring_list: "\<And>i. i < Suc n \<Longrightarrow> ring ((map (\<lambda>i. R Quot I i) [0..< Suc n]) ! i)"
+    using ideal.quotient_is_ring[OF assms]
+    by (metis add.left_neutral diff_zero le_simps(2) nth_map_upt)
+  show ?thesis
+    using RDirProd_list_is_ring[OF ring_list] by simp
+qed
+
+lemma (in ring) canonical_proj_ext_ring_hom:
   assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R"
-      and "\<And>i j. \<lbrakk> i \<le> n; j \<le> n; i \<noteq> j \<rbrakk> \<Longrightarrow> I i <+> I j = carrier R"
-    shows "(\<Inter>i \<le> n. I i) = a_kernel R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))
-                           (\<lambda>a. (map (\<lambda>i. (I i) +> a) [0..< Suc n]))"
+  shows "ring_hom_ring R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) (canonical_proj_ext I n)"
 proof -
-  let ?\<phi> = "\<lambda>a. (map (\<lambda>i. (I i) +> a) [0..< Suc n])"
+  have ring: "ring (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))"
+    using RDirProd_Quot_list_is_ring[OF assms] by simp  
   show ?thesis
-  proof
-    show "(\<Inter>i \<le> n. I i) \<subseteq> a_kernel R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) ?\<phi>"
-    proof
-      fix s assume s: "s \<in> (\<Inter>i \<le> n. I i)"
-      hence "\<And>i. i \<le> n \<Longrightarrow> (I i) +> s = I i"
-        by (simp add: additive_subgroup.zero_closed assms ideal.axioms(1) ideal.set_add_zero)
-      hence "\<And>i. i \<le> n \<Longrightarrow> (?\<phi> s) ! i = I i"
-        by (metis add.left_neutral diff_zero le_imp_less_Suc nth_map_upt)
-      moreover have
-        "\<And>i. i \<le> n \<Longrightarrow> (\<zero>\<^bsub>(RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))\<^esub>) ! i =
-                         \<zero>\<^bsub>(R Quot (I i))\<^esub>"
-        using RDirProd_list_zero[where ?Rs = "map (\<lambda>i. R Quot I i) [0..<Suc n]"]
-        by (metis (no_types, lifting) add.left_neutral le_imp_less_Suc
-            length_map length_upt nth_map_upt diff_zero)
-      hence 
-        "\<And>i. i \<le> n \<Longrightarrow> (\<zero>\<^bsub>(RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))\<^esub>) ! i = I i"
-        unfolding FactRing_def by simp
-      moreover
-      have "length (\<zero>\<^bsub>(RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))\<^esub>) = Suc n"
-        by (subst length_RDirProd_list_0) (simp_all add: length_RDirProd_list_0 assms(1) ideal.quotient_is_cring is_cring)
-      moreover have "length (?\<phi> s) = Suc n" by simp
-      ultimately have "?\<phi> s = \<zero>\<^bsub>(RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))\<^esub>"
-        by (simp add: list_eq_iff_nth_eq)
-      moreover have "s \<in> carrier R"
-        using additive_subgroup.a_Hcarr assms(1) ideal.axioms(1) s by fastforce
-      ultimately show "s \<in> a_kernel R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) ?\<phi>"
-        using a_kernel_def'[of R "RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])"] by simp
-    qed
+    using canonical_proj_ext_is_hom assms ring_hom_ring.intro[OF ring_axioms ring]
+    unfolding ring_hom_ring_axioms_def by blast
+qed
+
+lemma (in ring) canonical_proj_ext_ker:
+  assumes "\<And>i. i \<le> (n :: nat) \<Longrightarrow> ideal (I i) R"
+  shows "a_kernel R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) (canonical_proj_ext I n) = (\<Inter>i \<le> n. I i)"
+proof -
+  let ?map_Quot = "\<lambda>I n. map (\<lambda>i. R Quot (I i)) [0..< Suc n]"
+  let ?ker = "\<lambda>I n. a_kernel R (RDirProd_list (?map_Quot I n)) (canonical_proj_ext I n)"
+
+  from assms show ?thesis
+  proof (induct n arbitrary: I)
+    case 0 then have I: "ideal (I 0) R" by simp
+    show ?case
+      unfolding a_kernel_def' RDirProd_list_zero canonical_proj_ext_def FactRing_def
+      using ideal.rcos_const_imp_mem a_rcos_zero ideal.Icarr I by auto 
   next
-    show "a_kernel R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) ?\<phi> \<subseteq> (\<Inter>i \<le> n. I i)"
-    proof
-      fix s assume s: "s \<in> a_kernel R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) ?\<phi>"
-      hence "?\<phi> s = \<zero>\<^bsub>(RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))\<^esub>"
-        unfolding a_kernel_def kernel_def by (simp add: monoid.defs)
-      hence "(I i) +> s = \<zero>\<^bsub>(R Quot (I i))\<^esub>" if "i \<le> n" for i
-        using RDirProd_list_zero[where ?Rs = "map (\<lambda>i. R Quot I i) [0..<Suc n]"]
-          by (metis (no_types) that add.left_neutral diff_zero le_imp_less_Suc length_map length_upt nth_map_upt)
-      hence "\<And>i. i \<le> n \<Longrightarrow> (I i) +> s = I i"
-        unfolding FactRing_def by simp
-      moreover have "s \<in> carrier R"
-        using s unfolding a_kernel_def kernel_def by simp
-      ultimately show "s \<in> (\<Inter>i \<le> n. I i)"
-        using ideal.set_add_zero_imp_mem[where ?i = s and ?R = R] by (simp add: assms(1))
-    qed
+    case (Suc n)
+    hence I: "ideal (I 0) R" by simp
+    have map_simp: "?map_Quot I (Suc n) = (R Quot I 0) # (?map_Quot (\<lambda>i. I (Suc i)) n)"
+      by (induct n) (auto)
+    have ker_I0: "I 0 = a_kernel R (R Quot (I 0)) (\<lambda>a. (I 0) +> a)"
+      using ideal.rcos_const_imp_mem[OF I] a_rcos_zero[OF I] ideal.Icarr[OF I]
+      unfolding a_kernel_def' FactRing_def by auto
+    hence "?ker I (Suc n) = (?ker (\<lambda>i. I (Suc i)) n) \<inter> (I 0)"
+      unfolding a_kernel_def' map_simp RDirProd_list_zero' canonical_proj_ext_tl by auto
+    moreover have "?ker (\<lambda>i. I (Suc i)) n = (\<Inter>i \<le> n. I (Suc i))"
+      using Suc(1)[of "\<lambda>i. I (Suc i)"] Suc(2) by auto
+    ultimately show ?case
+      by (auto simp add: INT_extend_simps(10) atMost_atLeast0)
+         (metis atLeastAtMost_iff le_zero_eq not_less_eq_eq)
   qed
 qed
 
+lemma (in cring) canonical_proj_ext_is_surj:
+  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R" and "\<And>i j. \<lbrakk> i \<le> n; j \<le> n \<rbrakk> \<Longrightarrow> i \<noteq> j \<Longrightarrow> I i <+> I j = carrier R"
+  shows "(canonical_proj_ext I n) ` carrier R = carrier (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))"
+  using assms
+proof (induct n arbitrary: I)
+  case 0 show ?case
+    by (auto simp add: RDirProd_list_carrier FactRing_def A_RCOSETS_def')
+next
+  { fix S :: "'c ring" and T :: "'d ring" and f g
+    assume A: "ring T" "f \<in> ring_hom R S" "g \<in> ring_hom R T" "f ` carrier R \<subseteq> f ` (a_kernel R T g)"
+    have "(\<lambda>a. (f a, g a)) ` carrier R = (f ` carrier R) \<times> (g ` carrier R)"
+    proof
+      show "(\<lambda>a. (f a, g a)) ` carrier R \<subseteq> (f ` carrier R) \<times> (g ` carrier R)"
+        by blast
+    next
+      show "(f ` carrier R) \<times> (g ` carrier R) \<subseteq> (\<lambda>a. (f a, g a)) ` carrier R"
+      proof
+        fix t assume "t \<in> (f ` carrier R) \<times> (g ` carrier R)"
+        then obtain a b where a: "a \<in> carrier R" "f a = fst t" and b: "b \<in> carrier R" "g b = snd t"
+          by auto
+        obtain c where c: "c \<in> a_kernel R T g" "f c = f (a \<ominus> b)"
+          using A(4) minus_closed[OF a(1) b (1)] by auto
+        have "f (c \<oplus> b) = f (a \<ominus> b) \<oplus>\<^bsub>S\<^esub>  f b"
+          using ring_hom_memE(3)[OF A(2)] b c unfolding a_kernel_def' by auto
+        hence "f (c \<oplus> b) = f a"
+          using ring_hom_memE(3)[OF A(2) minus_closed[of a b], of b] a b by algebra
+        moreover have "g (c \<oplus> b) = g b"
+          using ring_hom_memE(1,3)[OF A(3)] b(1) c ring.ring_simprules(8)[OF A(1)]
+          unfolding a_kernel_def' by auto
+        ultimately have "(\<lambda>a. (f a, g a)) (c \<oplus> b) = t" and "c \<oplus> b \<in> carrier R"
+          using a b c unfolding a_kernel_def' by auto
+        thus "t \<in> (\<lambda>a. (f a, g a)) ` carrier R"
+          by blast
+      qed
+    qed } note aux_lemma = this
 
-subsection \<open>Final Generalization\<close>
+  let ?map_Quot = "\<lambda>I n. map (\<lambda>i. R Quot (I i)) [0..< Suc n]"
+  let ?DirProd = "\<lambda>I n. RDirProd_list (?map_Quot I n)"
+  let ?proj = "\<lambda>I n. canonical_proj_ext I n"
+
+  case (Suc n)
+  interpret I: ideal "I 0" R + Inter: ideal "\<Inter>i \<le> n. I (Suc i)" R
+    using i_Intersect[of "(\<lambda>i. I (Suc i)) ` {..n}"] Suc(2) by auto
+
+  have map_simp: "?map_Quot I (Suc n) = (R Quot I 0) # (?map_Quot (\<lambda>i. I (Suc i)) n)"
+    by (induct n) (auto)
+
+  have IH: "(?proj (\<lambda>i. I (Suc i)) n) ` carrier R = carrier (?DirProd (\<lambda>i. I (Suc i)) n)"
+   and ring: "ring (?DirProd (\<lambda>i. I (Suc i)) n)"
+   and hom: "?proj (\<lambda>i. I (Suc i)) n \<in> ring_hom R (?DirProd (\<lambda>i. I (Suc i)) n)"
+    using RDirProd_Quot_list_is_ring[of n "\<lambda>i. I (Suc i)"] Suc(1)[of "\<lambda>i. I (Suc i)"]
+           canonical_proj_ext_is_hom[of n "\<lambda>i. I (Suc i)"] Suc(2-3) by auto
+
+  have ker: "a_kernel R (?DirProd (\<lambda>i. I (Suc i)) n) (?proj (\<lambda>i. I (Suc i)) n) = (\<Inter>i \<le> n. I (Suc i))"
+    using canonical_proj_ext_ker[of n "\<lambda>i. I (Suc i)"] Suc(2) by auto
+  have carrier_Quot: "carrier (R Quot (I 0)) = (\<lambda>a. (I 0) +> a) ` carrier R"
+    by (auto simp add: RDirProd_list_carrier FactRing_def A_RCOSETS_def')
+  have ring: "ring (?DirProd (\<lambda>i. I (Suc i)) n)"
+   and hom: "?proj (\<lambda>i. I (Suc i)) n \<in> ring_hom R (?DirProd (\<lambda>i. I (Suc i)) n)"
+    using RDirProd_Quot_list_is_ring[of n "\<lambda>i. I (Suc i)"]
+          canonical_proj_ext_is_hom[of n "\<lambda>i. I (Suc i)"] Suc(2) by auto
+  have "carrier (R Quot (I 0)) \<subseteq> (\<lambda>a. (I 0) +> a) ` (\<Inter>i \<le> n. I (Suc i))"
+  proof
+    have "(\<Inter>i \<in> {Suc 0.. Suc n}. I i) <+> (I 0) = carrier R"
+      using inter_plus_ideal_eq_carrier_arbitrary[of n I 0]
+      by (simp add: Suc(2-3) atLeast1_atMost_eq_remove0)
+    hence eq_carrier: "(I 0) <+> (\<Inter>i \<le> n. I (Suc i)) = carrier R"
+      using set_add_comm[OF I.a_subset Inter.a_subset]
+      by (metis INT_extend_simps(10) atMost_atLeast0 image_Suc_atLeastAtMost)
+
+    fix b assume "b \<in> carrier (R Quot (I 0))"
+    hence "(b, (\<Inter>i \<le> n. I (Suc i))) \<in> carrier (R Quot I 0) \<times> carrier (R Quot (\<Inter>i\<le>n. I (Suc i)))"
+      using ring.ring_simprules(2)[OF Inter.quotient_is_ring] by (simp add: FactRing_def)
+    then obtain s
+      where "s \<in> carrier R" "(canonical_proj (I 0) (\<Inter>i \<le> n. I (Suc i))) s = (b, (\<Inter>i \<le> n. I (Suc i)))"
+      using canonical_proj_is_surj[OF I.is_ideal Inter.is_ideal eq_carrier]
+      unfolding RDirProd_carrier by (metis (no_types, lifting) imageE)
+    hence "s \<in> (\<Inter>i \<le> n. I (Suc i))" and "(\<lambda>a. (I 0) +> a) s = b"
+      using Inter.rcos_const_imp_mem by auto
+    thus "b \<in> (\<lambda>a. (I 0) +> a) ` (\<Inter>i \<le> n. I (Suc i))"
+      by auto
+  qed
+  hence "(\<lambda>a. ((I 0) +> a, ?proj (\<lambda>i. I (Suc i)) n a)) ` carrier R =
+         carrier (R Quot (I 0)) \<times> carrier (?DirProd (\<lambda>i. I (Suc i)) n)"
+    using aux_lemma[OF ring I.rcos_ring_hom hom] unfolding carrier_Quot ker IH by simp
+  moreover show ?case
+    unfolding map_simp RDirProd_list_carrier sym[OF calculation(1)] canonical_proj_ext_tl by auto 
+qed
 
 theorem (in cring) chinese_remainder:
-  fixes n::nat
-  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R"
-      and "\<And>i j. \<lbrakk> i \<le> n; j \<le> n; i \<noteq> j \<rbrakk> \<Longrightarrow> I i <+> I j = carrier R"
-    shows "R Quot (\<Inter>i \<le> n. I i) \<simeq>  RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])"
-  using assms
-proof (induct n)
-  case 0
-  have "(\<lambda>r. (r, [])) \<in> ring_iso (R Quot (I 0)) (RDirProd (R Quot (I 0)) (RDirProd_list []))"
-    unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def RDirProd_def
-    by (auto simp add: monoid.defs)
-  hence "(R Quot (I 0)) \<simeq> (RDirProd (R Quot (I 0)) (RDirProd_list []))"
-    unfolding is_ring_iso_def by blast
-  moreover
-  have "RDirProd ((R Quot (I 0)) :: 'a set ring)
-                 (RDirProd_list ([] :: (('a set) ring) list)) \<simeq> (RDirProd_list  [ (R Quot (I 0)) ])"
-    using RDirProd_list_isomorphism1'[of "(R Quot (I 0)) :: 'a set ring" "[] :: (('a set) ring) list"] . 
-  ultimately show ?case
-    using ring_iso_trans by simp
-next
-  case (Suc n)
-  have inter_ideal: "ideal (\<Inter> i \<le> n. I i) R"
-    using Suc.prems(1) i_Intersect[of "I ` {..n}"] atMost_Suc atLeast1_atMost_eq_remove0 by auto
-  hence "R Quot (\<Inter> i \<le> Suc n. I i) \<simeq> RDirProd (R Quot (\<Inter> i \<le> n. I i)) (R Quot (I (Suc n)))"
-    using chinese_remainder_simple[of "\<Inter> i \<le> n. I i" "I (Suc n)"] inter_plus_ideal_eq_carrier[of n I]
-    by (simp add: Int_commute Suc.prems(1-2) atMost_Suc)
-  moreover have "R Quot (\<Inter> i \<le> n. I i) \<simeq> RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])"
-    using Suc.hyps Suc.prems(1-2) by auto
-  hence "RDirProd (R Quot (\<Inter> i \<le> n. I i)) (R Quot (I (Suc n))) \<simeq>
-         RDirProd (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) (R Quot (I (Suc n)))"
-    unfolding is_ring_iso_def using RDirProd_isomorphism4 by blast
-  ultimately
-  have "R Quot (\<Inter> i \<le> Suc n. I i) \<simeq>
-        RDirProd (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) (R Quot (I (Suc n)))"
-    using ring_iso_trans by simp
-  moreover
-  have "RDirProd (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) (R Quot (I (Suc n))) \<simeq>
-        RDirProd_list ((map (\<lambda>i. R Quot (I i)) [0..< Suc n]) @ [ R Quot (I (Suc n)) ])"
-    using RDirProd_list_isomorphism3 unfolding is_ring_iso_def by blast
-  hence "RDirProd (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) (R Quot (I (Suc n))) \<simeq>
-         RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc (Suc n)])" by simp
-  ultimately show ?case using ring_iso_trans by simp
-qed
+  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R" and "\<And>i j. \<lbrakk> i \<le> n; j \<le> n \<rbrakk> \<Longrightarrow> i \<noteq> j \<Longrightarrow> I i <+> I j = carrier R"
+  shows "R Quot (\<Inter>i \<le> n. I i) \<simeq> RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])"
+  using ring_hom_ring.FactRing_iso[OF canonical_proj_ext_ring_hom, of n I]
+        canonical_proj_ext_is_surj[of n I] canonical_proj_ext_ker[of n I] assms
+  by auto
 
-end
+end
\ No newline at end of file
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Coset.thy
--- a/src/HOL/Algebra/Coset.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Coset.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -440,6 +440,13 @@
   shows "N \<lhd> G"
   using assms normal_inv_iff by blast
 
+corollary (in group) normal_invE:
+  assumes "N \<lhd> G"
+  shows "subgroup N G" and "\<And>x h. \<lbrakk> x \<in> carrier G; h \<in> N \<rbrakk> \<Longrightarrow> x \<otimes> h \<otimes> inv x \<in> N"
+  using assms normal_inv_iff apply blast
+  by (simp add: assms normal.inv_op_closed2)
+
+
 lemma (in group) one_is_normal: "{\<one>} \<lhd> G"
 proof(intro normal_invI)
   show "subgroup {\<one>} G"
@@ -1076,7 +1083,7 @@
 (* Next two lemmas contributed by Paulo Emílio de Vilhena. *)
 
 lemma (in group_hom) trivial_hom_iff:
-  "(h ` (carrier G) = { \<one>\<^bsub>H\<^esub> }) = (kernel G H h = carrier G)"
+  "h ` (carrier G) = { \<one>\<^bsub>H\<^esub> } \<longleftrightarrow> kernel G H h = carrier G"
   unfolding kernel_def using one_closed by force
 
 lemma (in group_hom) trivial_ker_imp_inj:
@@ -1091,6 +1098,90 @@
     using A G.inv_equality G.inv_inv by blast
 qed
 
+(* NEW ========================================================================== *)
+lemma (in group_hom) inj_iff_trivial_ker:
+  shows "inj_on h (carrier G) \<longleftrightarrow> kernel G H h = { \<one> }"
+proof
+  assume inj: "inj_on h (carrier G)" show "kernel G H h = { \<one> }"
+    unfolding kernel_def
+  proof (auto)
+    fix a assume "a \<in> carrier G" "h a = \<one>\<^bsub>H\<^esub>" thus "a = \<one>"
+      using inj hom_one unfolding inj_on_def by force
+  qed
+next
+  show "kernel G H h = { \<one> } \<Longrightarrow> inj_on h (carrier G)"
+    using trivial_ker_imp_inj by simp
+qed
+
+(* NEW ========================================================================== *)
+lemma (in group_hom) induced_group_hom':
+  assumes "subgroup I G" shows "group_hom (G \<lparr> carrier := I \<rparr>) H h"
+proof -
+  have "h \<in> hom (G \<lparr> carrier := I \<rparr>) H"
+    using homh subgroup.subset[OF assms] unfolding hom_def by (auto, meson hom_mult subsetCE)
+  thus ?thesis
+    using subgroup.subgroup_is_group[OF assms G.group_axioms] group_axioms
+    unfolding group_hom_def group_hom_axioms_def by auto
+qed
+
+(* NEW ========================================================================== *)
+lemma (in group_hom) inj_on_subgroup_iff_trivial_ker:
+  assumes "subgroup I G"
+  shows "inj_on h I \<longleftrightarrow> kernel (G \<lparr> carrier := I \<rparr>) H h = { \<one> }"
+  using group_hom.inj_iff_trivial_ker[OF induced_group_hom'[OF assms]] by simp
+
+(* NEW ========================================================================== *)
+lemma set_mult_hom:
+  assumes "h \<in> hom G H" "I \<subseteq> carrier G" and "J \<subseteq> carrier G"
+  shows "h ` (I <#>\<^bsub>G\<^esub> J) = (h ` I) <#>\<^bsub>H\<^esub> (h ` J)"
+proof
+  show "h ` (I <#>\<^bsub>G\<^esub> J) \<subseteq> (h ` I) <#>\<^bsub>H\<^esub> (h ` J)"
+  proof
+    fix a assume "a \<in> h ` (I <#>\<^bsub>G\<^esub> J)"
+    then obtain i j where i: "i \<in> I" and j: "j \<in> J" and "a = h (i \<otimes>\<^bsub>G\<^esub> j)"
+      unfolding set_mult_def by auto
+    hence "a = (h i) \<otimes>\<^bsub>H\<^esub> (h j)"
+      using assms unfolding hom_def by blast
+    thus "a \<in> (h ` I) <#>\<^bsub>H\<^esub> (h ` J)"
+      using i and j unfolding set_mult_def by auto
+  qed
+next
+  show "(h ` I) <#>\<^bsub>H\<^esub> (h ` J) \<subseteq> h ` (I <#>\<^bsub>G\<^esub> J)"
+  proof
+    fix a assume "a \<in> (h ` I) <#>\<^bsub>H\<^esub> (h ` J)"
+    then obtain i j where i: "i \<in> I" and j: "j \<in> J" and "a = (h i) \<otimes>\<^bsub>H\<^esub> (h j)"
+      unfolding set_mult_def by auto
+    hence "a = h (i \<otimes>\<^bsub>G\<^esub> j)"
+      using assms unfolding hom_def by fastforce
+    thus "a \<in> h ` (I <#>\<^bsub>G\<^esub> J)"
+      using i and j unfolding set_mult_def by auto
+  qed
+qed
+
+(* NEW ========================================================================== *)
+corollary coset_hom:
+  assumes "h \<in> hom G H" "I \<subseteq> carrier G" "a \<in> carrier G"
+  shows "h ` (a <#\<^bsub>G\<^esub> I) = h a <#\<^bsub>H\<^esub> (h ` I)" and "h ` (I #>\<^bsub>G\<^esub> a) = (h ` I) #>\<^bsub>H\<^esub> h a"
+  unfolding l_coset_eq_set_mult r_coset_eq_set_mult using assms set_mult_hom[OF assms(1)] by auto
+
+(* NEW ========================================================================== *)
+corollary (in group_hom) set_mult_ker_hom:
+  assumes "I \<subseteq> carrier G"
+  shows "h ` (I <#> (kernel G H h)) = h ` I" and "h ` ((kernel G H h) <#> I) = h ` I"
+proof -
+  have ker_in_carrier: "kernel G H h \<subseteq> carrier G"
+    unfolding kernel_def by auto
+
+  have "h ` (kernel G H h) = { \<one>\<^bsub>H\<^esub> }"
+    unfolding kernel_def by force
+  moreover have "h ` I \<subseteq> carrier H"
+    using assms by auto
+  hence "(h ` I) <#>\<^bsub>H\<^esub> { \<one>\<^bsub>H\<^esub> } = h ` I" and "{ \<one>\<^bsub>H\<^esub> } <#>\<^bsub>H\<^esub> (h ` I) = h ` I"
+    unfolding set_mult_def by force+
+  ultimately show "h ` (I <#> (kernel G H h)) = h ` I" and "h ` ((kernel G H h) <#> I) = h ` I"
+    using set_mult_hom[OF homh assms ker_in_carrier] set_mult_hom[OF homh ker_in_carrier assms] by simp+
+qed
+
 
 (* Next subsection contributed by Martin Baillon. *)
 
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Cycles.thy
--- a/src/HOL/Algebra/Cycles.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Cycles.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -8,8 +8,10 @@
 
 section \<open>Cycles\<close>
 
-abbreviation cycle :: "'a list \<Rightarrow> bool" where
-  "cycle cs \<equiv> distinct cs"
+subsection \<open>Definitions\<close>
+
+abbreviation cycle :: "'a list \<Rightarrow> bool"
+  where "cycle cs \<equiv> distinct cs"
 
 fun cycle_of_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a"
   where
@@ -17,41 +19,26 @@
   | "cycle_of_list cs = id"
 
 
-subsection\<open>Cycles as Rotations\<close>
+subsection \<open>Basic Properties\<close>
 
-text\<open>We start proving that the function derived from a cycle rotates its support list.\<close>
+text \<open>We start proving that the function derived from a cycle rotates its support list.\<close>
 
 lemma id_outside_supp:
-  assumes "cycle cs" and "x \<notin> set cs"
-  shows "(cycle_of_list cs) x = x" using assms
-proof (induction cs rule: cycle_of_list.induct)
-  case (1 i j cs)
-  have "cycle_of_list (i # j # cs) x = (Fun.swap i j id) (cycle_of_list (j # cs) x)" by simp
-  also have " ... = (Fun.swap i j id) x"
-    using "1.IH" "1.prems"(1) "1.prems"(2) by auto
-  also have " ... = x" using 1(3) by simp
-  finally show ?case .
-next
-  case "2_1" thus ?case by simp
-next
-  case "2_2" thus ?case by simp
-qed
+  assumes "x \<notin> set cs" shows "(cycle_of_list cs) x = x"
+  using assms by (induct cs rule: cycle_of_list.induct) (simp_all)
 
-lemma cycle_permutes:
-  assumes "cycle cs"
-  shows "permutation (cycle_of_list cs)"
-proof (induction rule: cycle_of_list.induct)
-  case (1 i j cs) thus ?case
-    by (metis cycle_of_list.simps(1) permutation_compose permutation_swap_id)
-next
-  case "2_1" thus ?case by simp
-next
-  case "2_2" thus ?case by simp
-qed
+lemma permutation_of_cycle: "permutation (cycle_of_list cs)"
+proof (induct cs rule: cycle_of_list.induct)
+  case 1 thus ?case
+    using permutation_compose[OF permutation_swap_id] unfolding comp_apply by simp
+qed simp_all
+
+lemma cycle_permutes: "(cycle_of_list cs) permutes (set cs)"
+  using permutation_bijective[OF permutation_of_cycle] id_outside_supp[of _ cs]
+  by (simp add: bij_iff permutes_def)
 
 theorem cyclic_rotation:
-  assumes "cycle cs"
-  shows "map ((cycle_of_list cs) ^^ n) cs = rotate n cs"
+  assumes "cycle cs" shows "map ((cycle_of_list cs) ^^ n) cs = rotate n cs"
 proof -
   { have "map (cycle_of_list cs) cs = rotate1 cs" using assms(1)
     proof (induction cs rule: cycle_of_list.induct)
@@ -72,92 +59,52 @@
         also have " ... = rotate1 (i # j # cs)" by simp
         finally show ?thesis .
       qed
-    next
-      case "2_1" thus ?case by simp
-    next
-      case "2_2" thus ?case by simp
-    qed }
+    qed simp_all }
   note cyclic_rotation' = this
 
-  from assms show ?thesis
-  proof (induction n)
-    case 0 thus ?case by simp
-  next
-    case (Suc n)
-    have "map ((cycle_of_list cs) ^^ (Suc n)) cs =
-          map (cycle_of_list cs) (map ((cycle_of_list cs) ^^ n) cs)" by simp
-    also have " ... = map (cycle_of_list cs) (rotate n cs)"
-      by (simp add: Suc.IH assms)
-    also have " ... = rotate (Suc n) cs"
-      using cyclic_rotation'
-      by (metis rotate1_rotate_swap rotate_Suc rotate_map)
-    finally show ?case .
-  qed
+  show ?thesis
+    using cyclic_rotation' by (induct n) (auto, metis map_map rotate1_rotate_swap rotate_map)
 qed
 
 corollary cycle_is_surj:
-  assumes "cycle cs"
-  shows "(cycle_of_list cs) ` (set cs) = (set cs)"
-  using cyclic_rotation[OF assms, of 1] by (simp add: image_set)
+  assumes "cycle cs" shows "(cycle_of_list cs) ` (set cs) = (set cs)"
+  using cyclic_rotation[OF assms, of "Suc 0"] by (simp add: image_set)
 
 corollary cycle_is_id_root:
-  assumes "cycle cs"
-  shows "(cycle_of_list cs) ^^ (length cs) = id"
+  assumes "cycle cs" shows "(cycle_of_list cs) ^^ (length cs) = id"
 proof -
   have "map ((cycle_of_list cs) ^^ (length cs)) cs = cs"
-    by (simp add: assms cyclic_rotation)
-  hence "\<And>x. x \<in> (set cs) \<Longrightarrow> ((cycle_of_list cs) ^^ (length cs)) x = x"
-    using map_eq_conv by fastforce
-  moreover have "\<And>n x. x \<notin> (set cs) \<Longrightarrow> ((cycle_of_list cs) ^^ n) x = x"
-  proof -
-    fix n show "\<And>x. x \<notin> (set cs) \<Longrightarrow> ((cycle_of_list cs) ^^ n) x = x"
-    proof (induction n)
-      case 0 thus ?case by simp
-    next
-      case (Suc n) thus ?case using id_outside_supp[OF assms] by simp
-    qed
-  qed
-  hence "\<And>x. x \<notin> (set cs) \<Longrightarrow> ((cycle_of_list cs) ^^ (length cs)) x = x" by simp
+    unfolding cyclic_rotation[OF assms] by simp
+  hence "((cycle_of_list cs) ^^ (length cs)) i = i" if "i \<in> set cs" for i
+    using that map_eq_conv by fastforce
+  moreover have "((cycle_of_list cs) ^^ n) i = i" if "i \<notin> set cs" for i n
+    using id_outside_supp[OF that] by (induct n) (simp_all)
   ultimately show ?thesis
-    by (meson eq_id_iff)
+    by fastforce
 qed
 
-corollary
-  assumes "cycle cs"
-  shows "(cycle_of_list cs) = (cycle_of_list (rotate n cs))"
+corollary cycle_of_list_rotate_independent:
+  assumes "cycle cs" shows "(cycle_of_list cs) = (cycle_of_list (rotate n cs))"
 proof -
-  { fix cs :: "'a list" assume A: "cycle cs"
+  { fix cs :: "'a list" assume cs: "cycle cs"
     have "(cycle_of_list cs) = (cycle_of_list (rotate1 cs))"
-    proof
-      have "\<And>x. x \<in> set cs \<Longrightarrow> (cycle_of_list cs) x = (cycle_of_list (rotate1 cs)) x"
-      proof -
-        have "cycle (rotate1 cs)" using A by simp
-        hence "map (cycle_of_list (rotate1 cs)) (rotate1 cs) = (rotate 2 cs)"
-          using cyclic_rotation by (metis Suc_eq_plus1 add.left_neutral
-          funpow.simps(2) funpow_simps_right(1) o_id one_add_one rotate_Suc rotate_def)
-        also have " ... = map (cycle_of_list cs) (rotate1 cs)"
-          using cyclic_rotation[OF A]
-          by (metis One_nat_def Suc_1 funpow.simps(2) id_apply map_map rotate0 rotate_Suc)
-        finally have "map (cycle_of_list (rotate1 cs)) (rotate1 cs) = 
-                    map (cycle_of_list cs) (rotate1 cs)" .
-        moreover fix x assume "x \<in> set cs"
-        ultimately show "(cycle_of_list cs) x = (cycle_of_list (rotate1 cs)) x" by auto
-      qed
-      moreover have "\<And>x. x \<notin> set cs \<Longrightarrow> (cycle_of_list cs) x = (cycle_of_list (rotate1 cs)) x"
-        using A by (simp add: id_outside_supp)
-      ultimately show "\<And>x. (cycle_of_list cs) x = (cycle_of_list (rotate1 cs)) x" by blast
-    qed }
-  note rotate1_lemma = this
+    proof -
+      from cs have rotate1_cs: "cycle (rotate1 cs)" by simp
+      hence "map (cycle_of_list (rotate1 cs)) (rotate1 cs) = (rotate 2 cs)"
+        using cyclic_rotation[OF rotate1_cs, of 1] by (simp add: numeral_2_eq_2)
+      moreover have "map (cycle_of_list cs) (rotate1 cs) = (rotate 2 cs)"
+        using cyclic_rotation[OF cs]
+        by (metis One_nat_def Suc_1 funpow.simps(2) id_apply map_map rotate0 rotate_Suc)
+      ultimately have "(cycle_of_list cs) i = (cycle_of_list (rotate1 cs)) i" if "i \<in> set cs" for i
+        using that map_eq_conv unfolding sym[OF set_rotate1[of cs]] by fastforce  
+      moreover have "(cycle_of_list cs) i = (cycle_of_list (rotate1 cs)) i" if "i \<notin> set cs" for i
+        using that by (simp add: id_outside_supp)
+      ultimately show "(cycle_of_list cs) = (cycle_of_list (rotate1 cs))"
+        by blast
+    qed } note rotate1_lemma = this
 
-  show "cycle_of_list cs = cycle_of_list (rotate n cs)"
-  proof (induction n)
-    case 0 thus ?case by simp
-  next
-    case (Suc n)
-    have "cycle (rotate n cs)" by (simp add: assms)
-    thus ?case using rotate1_lemma[of "rotate n cs"]
-      by (simp add: Suc.IH)
-  qed
+  show ?thesis
+    using rotate1_lemma[of "rotate n cs"] by (induct n) (auto, metis assms distinct_rotate rotate1_lemma)
 qed
 
 
@@ -190,563 +137,421 @@
 subsection\<open>When Cycles Commute\<close>
 
 lemma cycles_commute:
-  assumes "cycle \<sigma>1" "cycle \<sigma>2" and "set \<sigma>1 \<inter> set \<sigma>2 = {}"
-  shows "(cycle_of_list \<sigma>1) \<circ> (cycle_of_list \<sigma>2) = (cycle_of_list \<sigma>2) \<circ> (cycle_of_list \<sigma>1)"
-proof -
-  { fix \<pi>1 :: "'a list" and \<pi>2 :: "'a list" and x :: "'a"
-    assume A: "cycle \<pi>1" "cycle \<pi>2" "set \<pi>1 \<inter> set \<pi>2 = {}" "x \<in> set \<pi>1" "x \<notin> set \<pi>2"
-    have "((cycle_of_list \<pi>1) \<circ> (cycle_of_list \<pi>2)) x =
-          ((cycle_of_list \<pi>2) \<circ> (cycle_of_list \<pi>1)) x"
+  assumes "cycle p" "cycle q" and "set p \<inter> set q = {}"
+  shows "(cycle_of_list p) \<circ> (cycle_of_list q) = (cycle_of_list q) \<circ> (cycle_of_list p)"
+proof
+  { fix p :: "'a list" and q :: "'a list" and i :: "'a"
+    assume A: "cycle p" "cycle q" "set p \<inter> set q = {}" "i \<in> set p" "i \<notin> set q"
+    have "((cycle_of_list p) \<circ> (cycle_of_list q)) i =
+          ((cycle_of_list q) \<circ> (cycle_of_list p)) i"
     proof -
-      have "((cycle_of_list \<pi>1) \<circ> (cycle_of_list \<pi>2)) x = (cycle_of_list \<pi>1) x"
-        using id_outside_supp[OF A(2) A(5)] by simp
-      also have " ... = ((cycle_of_list \<pi>2) \<circ> (cycle_of_list \<pi>1)) x"
-        using id_outside_supp[OF A(2), of "(cycle_of_list \<pi>1) x"]
-              cycle_is_surj[OF A(1)] A(3) A(4) by fastforce
+      have "((cycle_of_list p) \<circ> (cycle_of_list q)) i = (cycle_of_list p) i"
+        using id_outside_supp[OF A(5)] by simp
+      also have " ... = ((cycle_of_list q) \<circ> (cycle_of_list p)) i"
+        using id_outside_supp[of "(cycle_of_list p) i"] cycle_is_surj[OF A(1)] A(3,4) by fastforce
       finally show ?thesis .
-    qed }
-  note aux_lemma = this
-
-  let ?\<sigma>12 = "\<lambda>x. ((cycle_of_list \<sigma>1) \<circ> (cycle_of_list \<sigma>2)) x"
-  let ?\<sigma>21 = "\<lambda>x. ((cycle_of_list \<sigma>2) \<circ> (cycle_of_list \<sigma>1)) x"
+    qed } note aui_lemma = this
 
-  show ?thesis
-  proof
-    fix x have "x \<in> set \<sigma>1 \<union> set \<sigma>2 \<or> x \<notin> set \<sigma>1 \<union> set \<sigma>2" by blast
-    from this show "?\<sigma>12 x = ?\<sigma>21 x"
-    proof 
-      assume "x \<in> set \<sigma>1 \<union> set \<sigma>2"
-      hence "(x \<in> set \<sigma>1 \<and> x \<notin> set \<sigma>2) \<or> (x \<notin> set \<sigma>1 \<and> x \<in> set \<sigma>2)" using assms(3) by blast
-      from this show "?\<sigma>12 x = ?\<sigma>21 x"
-      proof
-        assume "x \<in> set \<sigma>1 \<and> x \<notin> set \<sigma>2" thus ?thesis
-          using aux_lemma[OF assms(1-3)] by simp
-      next
-        assume "x \<notin> set \<sigma>1 \<and> x \<in> set \<sigma>2" thus ?thesis
-          using assms aux_lemma inf_commute by metis
-      qed
-    next
-      assume "x \<notin> set \<sigma>1 \<union> set \<sigma>2" thus ?thesis using id_outside_supp assms(1-2)
-        by (metis UnCI comp_apply)
-    qed
+  fix i consider "i \<in> set p" "i \<notin> set q" | "i \<notin> set p" "i \<in> set q" | "i \<notin> set p" "i \<notin> set q"
+    using \<open>set p \<inter> set q = {}\<close> by blast
+  thus "((cycle_of_list p) \<circ> (cycle_of_list q)) i = ((cycle_of_list q) \<circ> (cycle_of_list p)) i"
+  proof cases
+    case 1 thus ?thesis
+      using aui_lemma[OF assms] by simp
+  next
+    case 2 thus ?thesis
+      using aui_lemma[OF assms(2,1)] assms(3) by (simp add: ac_simps(8))
+  next
+    case 3 thus ?thesis
+      by (simp add: id_outside_supp)
   qed
 qed
 
 
-subsection\<open>Cycles from Permutations\<close>
+subsection \<open>Cycles from Permutations\<close>
+
+subsubsection \<open>Exponentiation of permutations\<close>
 
-subsubsection\<open>Exponentiation of permutations\<close>
+text \<open>Some important properties of permutations before defining how to extract its cycles.\<close>
 
-text\<open>Some important properties of permutations before defining how to extract its cycles\<close>
+lemma permutation_funpow:
+  assumes "permutation p" shows "permutation (p ^^ n)"
+  using assms by (induct n) (simp_all add: permutation_compose)
 
-lemma exp_of_permutation1:
-  assumes "p permutes S"
-  shows "(p ^^ n) permutes S" using assms
-proof (induction n)
-  case 0 thus ?case by (simp add: permutes_def) 
-next
-  case (Suc n) thus ?case by (metis funpow_Suc_right permutes_compose) 
-qed
+lemma permutes_funpow:
+  assumes "p permutes S" shows "(p ^^ n) permutes S"
+  using assms by (induct n) (simp add: permutes_def, metis funpow_Suc_right permutes_compose)
 
-lemma exp_of_permutation2:
-  assumes "p permutes S"
-    and "i < j" "(p ^^ j) = (p ^^ i)"
-  shows "(p ^^ (j - i)) = id" using assms
+lemma funpow_diff:
+  assumes "inj p" and "i \<le> j" "(p ^^ i) a = (p ^^ j) a" shows "(p ^^ (j - i)) a = a"
 proof -
-  have "(p ^^ i) \<circ> (p ^^ (j - i)) = (p ^^ j)"
-    by (metis add_diff_inverse_nat assms(2) funpow_add le_eq_less_or_eq not_le)
-  also have " ... = (p ^^ i)" using assms(3) by simp
-  finally have "(p ^^ i) \<circ> (p ^^ (j - i)) = (p ^^ i)" .
-  moreover have "bij (p ^^ i)" using exp_of_permutation1[OF assms(1)]
-    using permutes_bij by auto
-  ultimately show ?thesis
-    by (metis (no_types, lifting) bij_is_inj comp_assoc fun.map_id inv_o_cancel)
+  have "(p ^^ i) ((p ^^ (j - i)) a) = (p ^^ i) a"
+    using assms(2-3) by (metis (no_types) add_diff_inverse_nat funpow_add not_le o_def)
+  thus ?thesis
+    unfolding inj_eq[OF inj_fn[OF assms(1)], of i] .
 qed
 
-lemma exp_of_permutation3:
-  assumes "p permutes S" "finite S"
-  shows "\<exists>n. (p ^^ n) = id \<and> n > 0"
-proof (rule ccontr)
-  assume "\<nexists>n. (p ^^ n) = id \<and> 0 < n"
-  hence S: "\<And>n. n > 0 \<Longrightarrow> (p ^^ n) \<noteq> id" by auto
-  hence "\<And>i j. \<lbrakk> i \<ge> 0; j \<ge> 0 \<rbrakk> \<Longrightarrow> i \<noteq> j \<Longrightarrow> (p ^^ i) \<noteq> (p ^^ j)"
-  proof -
-    fix i :: "nat" and j :: "nat" assume "i \<ge> 0" "j \<ge> 0" and Ineq: "i \<noteq> j"
-    show "(p ^^ i) \<noteq> (p ^^ j)"
-    proof (rule ccontr)
-      assume "\<not> (p ^^ i) \<noteq> (p ^^ j)" hence Eq: "(p ^^ i) = (p ^^ j)" by simp
-      have "(p ^^ (j - i)) = id" if "j > i"
-        using Eq exp_of_permutation2[OF assms(1) that] by simp
-      moreover have "(p ^^ (i - j)) = id" if "i > j"
-        using Eq exp_of_permutation2[OF assms(1) that] by simp
-      ultimately show False using Ineq S
-        by (meson le_eq_less_or_eq not_le zero_less_diff)
-    qed
+lemma permutation_is_nilpotent:
+  assumes "permutation p" obtains n where "(p ^^ n) = id" and "n > 0"
+proof -
+  obtain S where "finite S" and "p permutes S"
+    using assms unfolding permutation_permutes by blast
+  hence "\<exists>n. (p ^^ n) = id \<and> n > 0"
+  proof (induct S arbitrary: p)
+    case empty thus ?case
+      using id_funpow[of 1] unfolding permutes_empty by blast
+  next
+    case (insert s S)
+    have "(\<lambda>n. (p ^^ n) s) ` UNIV \<subseteq> (insert s S)"
+      using permutes_in_image[OF permutes_funpow[OF insert(4)], of _ s] by auto
+    hence "\<not> inj_on (\<lambda>n. (p ^^ n) s)  UNIV"
+      using insert(1) infinite_iff_countable_subset unfolding sym[OF finite_insert, of S s] by metis
+    then obtain i j where ij: "i < j" "(p ^^ i) s = (p ^^ j) s"
+      unfolding inj_on_def by (metis nat_neq_iff) 
+    hence "(p ^^ (j - i)) s = s"
+      using funpow_diff[OF permutes_inj[OF insert(4)]] le_eq_less_or_eq by blast
+    hence "p ^^ (j - i) permutes S"
+      using permutes_superset[OF permutes_funpow[OF insert(4), of "j - i"], of S] by auto
+    then obtain n where n: "((p ^^ (j - i)) ^^ n) = id" "n > 0"
+      using insert(3) by blast
+    thus ?case
+      using ij(1) nat_0_less_mult_iff zero_less_diff unfolding funpow_mult by metis 
   qed
-  hence "bij_betw (\<lambda>i. (p ^^ i)) {i :: nat . i \<ge> 0} {(p ^^ i) | i :: nat . i \<ge> 0}"
-    unfolding bij_betw_def inj_on_def by blast
-  hence "infinite {(p ^^ i) | i :: nat . i \<ge> 0}"
-    using bij_betw_finite by auto
-  moreover have "{(p ^^ i) | i :: nat . i \<ge> 0} \<subseteq> {\<pi>. \<pi> permutes S}"
-    using exp_of_permutation1[OF assms(1)] by blast
-  hence "finite {(p ^^ i) | i :: nat . i \<ge> 0}"
-    by (simp add: assms(2) finite_permutations finite_subset)
-  ultimately show False ..
+  thus thesis
+    using that by blast
 qed
 
-lemma power_prop:
-  assumes "(p ^^ k) x = x" 
-  shows "(p ^^ (k * l)) x = x"
-proof (induction l)
-  case 0 thus ?case by simp
-next
-  case (Suc l)
-  hence "(p ^^ (k * (Suc l))) x = ((p ^^ (k * l)) \<circ> (p ^^ k)) x"
-    by (metis funpow_Suc_right funpow_mult)
-  also have " ... = (p ^^ (k * l)) x"
-    by (simp add: assms)
-  also have " ... = x"
-    using Suc.IH Suc.prems assms by blast
-  finally show ?case . 
-qed
-
-lemma exp_of_permutation4:
-  assumes "p permutes S" "finite S"
-  shows "\<exists>n. (p ^^ n) = id \<and> n > m"
+lemma permutation_is_nilpotent':
+  assumes "permutation p" obtains n where "(p ^^ n) = id" and "n > m"
 proof -
-  obtain k where "k > 0" "(p ^^ k) = id"
-    using exp_of_permutation3[OF assms] by blast
-  moreover obtain n where "n * k > m"
-    by (metis calculation(1) dividend_less_times_div mult.commute mult_Suc_right)
-  ultimately show ?thesis
-      by (metis (full_types) funpow_mult id_funpow mult.commute)
+  obtain n where "(p ^^ n) = id" and "n > 0"
+    using permutation_is_nilpotent[OF assms] by blast
+  then obtain k where "n * k > m"
+    by (metis dividend_less_times_div mult_Suc_right)
+  from \<open>(p ^^ n) = id\<close> have "p ^^ (n * k) = id"
+    by (induct k) (simp, metis funpow_mult id_funpow)
+  with \<open>n * k > m\<close> show thesis
+    using that by blast
 qed
 
 
-subsubsection\<open>Extraction of cycles from permutations\<close>
+subsubsection \<open>Extraction of cycles from permutations\<close>
 
-definition
-  least_power :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> nat"
+definition least_power :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> nat"
   where "least_power f x = (LEAST n. (f ^^ n) x = x \<and> n > 0)"
 
-abbreviation
-  support :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list"
+abbreviation support :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list"
   where "support p x \<equiv> map (\<lambda>i. (p ^^ i) x) [0..< (least_power p x)]"
 
-lemma least_power_wellfounded:
-  assumes "permutation p"
-  shows "(p ^^ (least_power p x)) x = x"
-proof -
-  obtain S where "p permutes S" "finite S"
-    using assms permutation_permutes by blast
-  hence "\<exists>n. (p ^^ n) x = x \<and> n > 0"
-    using eq_id_iff exp_of_permutation3 by metis
-  thus ?thesis unfolding least_power_def
-    by (metis (mono_tags, lifting) LeastI_ex)
-qed
+
+lemma least_powerI:
+  assumes "(f ^^ n) x = x" and "n > 0"
+  shows "(f ^^ (least_power f x)) x = x" and "least_power f x > 0"
+  using assms unfolding least_power_def by (metis (mono_tags, lifting) LeastI)+
 
-lemma least_power_gt_zero:
-  assumes "permutation p"
-  shows "least_power p x > 0"
-proof (rule ccontr)
-  obtain S where "p permutes S" "finite S"
-    using assms permutation_permutes by blast
-  hence Ex: "\<exists>n. (p ^^ n) x = x \<and> n > 0"
-    using eq_id_iff exp_of_permutation3 by metis
-  assume "\<not> 0 < least_power p x" hence "least_power p x = 0"
-    using Ex unfolding least_power_def by (metis (mono_tags, lifting) LeastI)
-  thus False unfolding least_power_def
-    by (metis (mono_tags, lifting) Ex LeastI_ex less_irrefl) 
-qed
+lemma least_power_le:
+  assumes "(f ^^ n) x = x" and "n > 0" shows "least_power f x \<le> n"
+  using assms unfolding least_power_def by (simp add: Least_le)
+
+lemma least_power_of_permutation:
+  assumes "permutation p" shows "(p ^^ (least_power p a)) a = a" and "least_power p a > 0"
+  using permutation_is_nilpotent[OF assms] least_powerI by (metis id_apply)+
 
 lemma least_power_gt_one:
-  assumes "permutation p" "p x \<noteq> x"
-  shows "least_power p x > Suc 0"
-proof (rule ccontr)
-  obtain S where "p permutes S" "finite S"
-    using assms permutation_permutes by blast
-  hence Ex: "\<exists>n. (p ^^ n) x = x \<and> n > 0"
-    using eq_id_iff exp_of_permutation3 by metis
-  assume "\<not> Suc 0 < least_power p x" hence "least_power p x = (Suc 0)"
-    using Ex unfolding least_power_def by (metis (mono_tags, lifting) LeastI Suc_lessI)
-  hence "p x = x" using least_power_wellfounded[OF assms(1), of x] by simp
-  from \<open>p x = x\<close> and \<open>p x \<noteq> x\<close> show False by simp
+  assumes "permutation p" and "p a \<noteq> a" shows "least_power p a > Suc 0"
+  using least_power_of_permutation[OF assms(1)] assms(2)
+  by (metis Suc_lessI funpow.simps(2) funpow_simps_right(1) o_id) 
+
+lemma least_power_minimal:
+  assumes "(p ^^ n) a = a" shows "(least_power p a) dvd n"
+proof (cases "n = 0", simp)
+  let ?lpow = "least_power p"
+
+  assume "n \<noteq> 0" then have "n > 0" by simp
+  hence "(p ^^ (?lpow a)) a = a" and "least_power p a > 0"
+    using assms unfolding least_power_def by (metis (mono_tags, lifting) LeastI)+
+  hence aux_lemma: "(p ^^ ((?lpow a) * k)) a = a" for k :: nat
+    by (induct k) (simp_all add: funpow_add)
+
+  have "(p ^^ (n mod ?lpow a)) ((p ^^ (n - (n mod ?lpow a))) a) = (p ^^ n) a"
+    by (metis add_diff_inverse_nat funpow_add mod_less_eq_dividend not_less o_apply)
+  with \<open>(p ^^ n) a = a\<close> have "(p ^^ (n mod ?lpow a)) a = a"
+    using aux_lemma by (simp add: minus_mod_eq_mult_div) 
+  hence "?lpow a \<le> n mod ?lpow a" if "n mod ?lpow a > 0"
+    using least_power_le[OF _ that, of p a] by simp
+  with \<open>least_power p a > 0\<close> show "(least_power p a) dvd n"
+    using mod_less_divisor not_le by blast
 qed
 
-lemma least_power_bound:
-  assumes "permutation p" shows "\<exists>m > 0. (least_power p x) \<le> m"
-proof -
-  obtain S where "p permutes S" "finite S"
-    using assms permutation_permutes by blast
-  hence "\<exists>n. (p ^^ n) x = x \<and> n > 0"
-    using eq_id_iff exp_of_permutation3 by metis
-  then obtain m :: "nat"  where "m > 0" "m = (least_power p x)"
-    unfolding least_power_def by (metis (mono_tags, lifting) LeastI_ex)
-  thus ?thesis by blast
+lemma least_power_dvd:
+  assumes "permutation p" shows "(least_power p a) dvd n \<longleftrightarrow> (p ^^ n) a = a"
+proof
+  show "(p ^^ n) a = a \<Longrightarrow> (least_power p a) dvd n"
+    using least_power_minimal[of _ p] by simp
+next
+  have "(p ^^ ((least_power p a) * k)) a = a" for k :: nat
+    using least_power_of_permutation(1)[OF assms(1)] by (induct k) (simp_all add: funpow_add)
+  thus "(least_power p a) dvd n \<Longrightarrow> (p ^^ n) a = a" by blast
 qed
 
-lemma lt_least_power:
-  assumes "Suc n = least_power p x"
-    and "0 < i" "i \<le> n"
-  shows "(p ^^ i) x \<noteq> x"
-proof (rule ccontr)
-  assume "\<not> (p ^^ i) x \<noteq> x" hence "(p ^^ i) x = x" by simp
-  hence "i \<in> {n. (p ^^ n) x = x \<and> n > 0}"
-    using assms(2-3) by blast
-  moreover have "i < least_power p x"
-    using assms(3) assms(1) by linarith
-  ultimately show False unfolding least_power_def
-    using not_less_Least by auto
+theorem cycle_of_permutation:
+  assumes "permutation p" shows "cycle (support p a)"
+proof -
+  have "(least_power p a) dvd (j - i)" if "i \<le> j" "j < least_power p a" and "(p ^^ i) a = (p ^^ j) a" for i j
+    using funpow_diff[OF bij_is_inj that(1,3)] assms by (simp add: permutation least_power_dvd)
+  moreover have "i = j" if "i \<le> j" "j < least_power p a" and "(least_power p a) dvd (j - i)" for i j
+    using that le_eq_less_or_eq nat_dvd_not_less by auto
+  ultimately have "inj_on (\<lambda>i. (p ^^ i) a) {..< (least_power p a)}"
+    unfolding inj_on_def by (metis le_cases lessThan_iff)
+  thus ?thesis
+    by (simp add: atLeast_upt distinct_map)
 qed
 
-lemma least_power_welldefined:
-  assumes "permutation p" and "y \<in> {(p ^^ k) x | k. k \<ge> 0}"
-  shows "least_power p x = least_power p y"
-proof -
-  have aux_lemma: "\<And>z. least_power p z = least_power p (p z)"
-  proof -
-    fix z
-    have "(p ^^ (least_power p z)) z = z"
-      by (metis assms(1) least_power_wellfounded)
-    hence "(p ^^ (least_power p z)) (p z) = (p z)"
-      by (metis funpow_swap1)
-    hence "least_power p z \<ge> least_power p (p z)"
-      by (metis assms(1) inc_induct le_SucE least_power_gt_zero lt_least_power nat_le_linear)
+
+subsection \<open>Decomposition on Cycles\<close>
+
+text \<open>We show that a permutation can be decomposed on cycles\<close>
+
+subsubsection \<open>Preliminaries\<close>
 
-    moreover have "(p ^^ (least_power p (p z))) (p z) = (p z)"
-      by (simp add: assms(1) least_power_wellfounded)
-    hence "(p ^^ (least_power p (p z))) z = z"
-      by (metis assms(1) funpow_swap1 permutation_permutes permutes_def)
-    hence "least_power p z \<le> least_power p (p z)"
-      by (metis assms(1) least_power_gt_zero less_imp_Suc_add lt_least_power not_less_eq_eq)
-
-    ultimately show "least_power p z = least_power p (p z)" by simp 
-  qed
-
-  obtain k where "k \<ge> 0" "y = (p ^^ k) x"
-    using assms(2) by blast
-  thus ?thesis
-  proof (induction k arbitrary: x y)
-    case 0 thus ?case by simp
-  next
-    case (Suc k)
-    have "least_power p ((p ^^ k) x) = least_power p x"
-      using Suc.IH by fastforce
-    thus ?case using aux_lemma
-      using Suc.prems(2) by auto
+lemma support_set:
+  assumes "permutation p" shows "set (support p a) = range (\<lambda>i. (p ^^ i) a)"
+proof
+  show "set (support p a) \<subseteq> range (\<lambda>i. (p ^^ i) a)"
+    by auto
+next
+  show "range (\<lambda>i. (p ^^ i) a) \<subseteq> set (support p a)"
+  proof (auto)
+    fix i
+    have "(p ^^ i) a = (p ^^ (i mod (least_power p a))) ((p ^^ (i - (i mod (least_power p a)))) a)"
+      by (metis add_diff_inverse_nat funpow_add mod_less_eq_dividend not_le o_apply)
+    also have " ... = (p ^^ (i mod (least_power p a))) a"
+      using least_power_dvd[OF assms] by (metis dvd_minus_mod)
+    also have " ... \<in> (\<lambda>i. (p ^^ i) a) ` {0..< (least_power p a)}"
+      using least_power_of_permutation(2)[OF assms] by fastforce
+    finally show "(p ^^ i) a \<in> (\<lambda>i. (p ^^ i) a) ` {0..< (least_power p a)}" .
   qed
 qed
 
-theorem cycle_of_permutation:
-  assumes "permutation p"
-  shows "cycle (support p x)"
-proof (rule ccontr)
-  assume "\<not> cycle (support p x)"
-  hence "\<exists> i j. i \<in> {0..<least_power p x} \<and> j \<in> {0..<least_power p x} \<and> i \<noteq> j \<and> (p ^^ i) x = (p ^^ j) x"
-    using atLeast_upt by (simp add: distinct_conv_nth) 
-  then obtain i j where ij: "0 \<le> i" "i < j" "j < least_power p x"
-                    and "(p ^^ i) x = (p ^^ j) x"
-    by (metis atLeast_upt le0 le_eq_less_or_eq lessThan_iff not_less set_upt)
-  hence "(p ^^ i) x = (p ^^ i) ((p ^^ (j - i)) x)"
-    by (metis add_diff_inverse_nat funpow_add not_less_iff_gr_or_eq o_apply)
-  hence "(p ^^ (j - i)) x = x"
-    using exp_of_permutation1 assms by (metis bij_pointE permutation_permutes permutes_bij)
-  moreover have "0 \<le> j - i \<and> j - i < least_power p x"
-    by (simp add: ij(3) less_imp_diff_less)
-  hence "(p ^^ (j - i)) x \<noteq> x" using lt_least_power ij
-    by (metis diff_le_self lessE less_imp_diff_less less_imp_le zero_less_diff)
-  ultimately show False by simp
+lemma disjoint_support:
+  assumes "permutation p" shows "disjoint (range (\<lambda>a. set (support p a)))" (is "disjoint ?A")
+proof (rule disjointI)
+  { fix i j a b
+    assume "set (support p a) \<inter> set (support p b) \<noteq> {}" have "set (support p a) \<subseteq> set (support p b)"
+      unfolding support_set[OF assms]
+    proof (auto)
+      from \<open>set (support p a) \<inter> set (support p b) \<noteq> {}\<close>
+      obtain i j where ij: "(p ^^ i) a = (p ^^ j) b"
+        by auto
+
+      fix k
+      have "(p ^^ k) a = (p ^^ (k + (least_power p a) * l)) a" for l
+        using least_power_dvd[OF assms] by (induct l) (simp, metis dvd_triv_left funpow_add o_def)
+      then obtain m where "m \<ge> i" and "(p ^^ m) a = (p ^^ k) a"
+        using least_power_of_permutation(2)[OF assms]
+        by (metis dividend_less_times_div le_eq_less_or_eq mult_Suc_right trans_less_add2)
+      hence "(p ^^ m) a = (p ^^ (m - i)) ((p ^^ i) a)"
+        by (metis Nat.le_imp_diff_is_add funpow_add o_apply)
+      with \<open>(p ^^ m) a = (p ^^ k) a\<close> have "(p ^^ k) a = (p ^^ ((m - i) + j)) b"
+        unfolding ij by (simp add: funpow_add)
+      thus "(p ^^ k) a \<in> range (\<lambda>i. (p ^^ i) b)"
+        by blast
+    qed } note aux_lemma = this
+
+  fix supp_a supp_b
+  assume "supp_a \<in> ?A" and "supp_b \<in> ?A"
+  then obtain a b where a: "supp_a = set (support p a)" and b: "supp_b = set (support p b)"
+    by auto
+  assume "supp_a \<noteq> supp_b" thus "supp_a \<inter> supp_b = {}"
+    using aux_lemma unfolding a b by blast  
 qed
 
-
-subsection\<open>Decomposition on Cycles\<close>
-
-text\<open>We show that a permutation can be decomposed on cycles\<close>
-
-subsubsection\<open>Preliminaries\<close>
-
-lemma support_set:
+lemma disjoint_support':
   assumes "permutation p"
-  shows "set (support p x) = {(p ^^ k) x | k. k \<ge> 0}"
+  shows "set (support p a) \<inter> set (support p b) = {} \<longleftrightarrow> a \<notin> set (support p b)"
 proof -
-  have "{(p ^^ k) x | k. k \<ge> 0} = {(p ^^ k) x | k. 0 \<le> k \<and> k < (least_power p x)}" (is "?A = ?B")
+  have "a \<in> set (support p a)"
+    using least_power_of_permutation(2)[OF assms] by force
+  show ?thesis
   proof
-    show "?B \<subseteq> ?A" by blast
-  next
-    show "?A \<subseteq> ?B"
-    proof
-      fix y assume "y \<in> ?A"
-      then obtain k :: "nat" where k: "k \<ge> 0" "(p ^^ k) x = y" by blast
-      hence "k = (least_power p x) * (k div (least_power p x)) + (k mod (least_power p x))" by simp
-      hence "y = (p ^^ ((least_power p x) * (k div (least_power p x)) + (k mod (least_power p x)))) x"
-        using k by auto
-      hence " y = (p ^^ (k mod (least_power p x))) x"
-        using power_prop[OF least_power_wellfounded[OF assms, of x], of "k div (least_power p x)"]
-        by (metis add.commute funpow_add o_apply)
-      moreover have "k mod (least_power p x) < least_power p x"
-        using k mod_less_divisor[of "least_power p x" k, OF least_power_gt_zero[OF assms]] by simp
-      ultimately show "y \<in> ?B"
-        by blast
-    qed
-  qed
-
-  moreover have "{(p ^^ k) x | k. 0 \<le> k \<and> k < (least_power p x)} = set (support p x)" (is "?B = ?C")
-  proof
-    show "?B \<subseteq> ?C"
-    proof
-      fix y assume "y \<in> {(p ^^ k) x | k. 0 \<le> k \<and> k < (least_power p x)}"
-      then obtain k where "k \<ge> 0" "k < (least_power p x)" "y = (p ^^ k) x" by blast
-      thus "y \<in> ?C" by auto
-    qed
+    assume "set (support p a) \<inter> set (support p b) = {}"
+    with \<open>a \<in> set (support p a)\<close> show "a \<notin> set (support p b)"
+      by blast
   next
-    show "?C \<subseteq> ?B"
-    proof
-      fix y assume "y \<in> ?C"
-      then obtain k where "k \<ge> 0" "k < (least_power p x)" "(support p x) ! k = y" by auto
-      thus "y \<in> ?B" by auto
+    assume "a \<notin> set (support p b)" show "set (support p a) \<inter> set (support p b) = {}"
+    proof (rule ccontr)
+      assume "set (support p a) \<inter> set (support p b) \<noteq> {}"
+      hence "set (support p a) = set (support p b)"
+        using disjoint_support[OF assms] by (meson UNIV_I disjoint_def image_iff)
+      with \<open>a \<in> set (support p a)\<close> and \<open>a \<notin> set (support p b)\<close> show False
+        by simp
     qed
   qed
-
-  ultimately show ?thesis by simp
-qed
-
-lemma disjoint_support:
-  assumes "p permutes S" "finite S"
-  shows "disjoint {{(p ^^ k) x | k. k \<ge> 0} | x. x \<in> S}" (is "disjoint ?A")
-proof (rule disjointI)
-  { fix a b assume "a \<in> ?A" "b \<in> ?A" "a \<inter> b \<noteq> {}"
-    then obtain x y where x: "x \<in> S" "a = {(p ^^ k) x | k. k \<ge> 0}"
-                      and y: "y \<in> S" "b = {(p ^^ k) y | k. k \<ge> 0}" by blast 
-    assume "a \<inter> b \<noteq> {}"
-    then obtain z kx ky where z: "kx \<ge> 0" "ky \<ge> 0" "z = (p ^^ kx) x" "z = (p ^^ ky) y"
-      using x(2) y(2) by blast
-    have "a \<subseteq> b"
-    proof
-      fix w assume "w \<in> a"
-      then obtain k where k: "k \<ge> 0" "w = (p ^^ k) x" using x by blast
-      define l where "l = (kx div (least_power p w)) + 1"
-      hence l: "l * (least_power p w) > kx"
-        using least_power_gt_zero assms One_nat_def add.right_neutral add_Suc_right
-            mult.commute permutation_permutes
-        by (metis dividend_less_times_div mult_Suc_right) 
-
-      have "w = (p ^^ (l * (least_power p w))) w"
-        by (metis assms least_power_wellfounded mult.commute permutation_permutes power_prop)
-      also have "... = (p ^^ (l * (least_power p w) + k)) x"
-        using k by (simp add: funpow_add) 
-      also have " ... = (p ^^ (l * (least_power p w) + k - kx + kx)) x"
-        using l by auto
-      also have " ... = (p ^^ (l * (least_power p w) + k - kx)) ((p ^^ kx) x)"
-        by (simp add: funpow_add)
-      also have " ... = (p ^^ (l * (least_power p w) + k - kx)) ((p ^^ ky) y)" using z
-        by simp
-      finally have "w = (p ^^ (l * (least_power p w) + k - kx + ky)) y"
-        by (simp add: funpow_add)
-      thus "w \<in> b" using y by blast
-    qed } note aux_lemma = this
-
-  fix a b assume ab: "a \<in> ?A" "b \<in> ?A" "a \<noteq> b"
-  show "a \<inter> b = {}"
-  proof (rule ccontr)
-    assume "a \<inter> b \<noteq> {}" thus False using aux_lemma ab
-      by (metis (no_types, lifting) inf.absorb2 inf.orderE)
-  qed
 qed
 
 lemma support_coverture:
-  assumes "p permutes S" "finite S"
-  shows "\<Union>{{(p ^^ k) x | k. k \<ge> 0} | x. x \<in> S} = S"
+  assumes "permutation p" shows "\<Union> { set (support p a) | a. p a \<noteq> a } = { a. p a \<noteq> a }"
 proof
-  show "\<Union>{{(p ^^ k) x |k. 0 \<le> k} |x. x \<in> S} \<subseteq> S"
+  show "{ a. p a \<noteq> a } \<subseteq> \<Union> { set (support p a) | a. p a \<noteq> a }"
   proof
-    fix y assume "y \<in> \<Union>{{(p ^^ k) x |k. 0 \<le> k} |x. x \<in> S}"
-    then obtain x k where x: "x \<in> S" and k: "k \<ge> 0" and y: "y = (p ^^ k) x" by blast
-    have "(p ^^ k) x \<in> S"
-    proof (induction k)
-      case 0 thus ?case using x by simp
-    next
-      case (Suc k) thus ?case using assms
-        by (simp add: permutes_in_image) 
-    qed
-    thus "y \<in> S" using y by simp
+    fix a assume "a \<in> { a. p a \<noteq> a }"
+    have "a \<in> set (support p a)"
+      using least_power_of_permutation(2)[OF assms, of a] by force
+    with \<open>a \<in> { a. p a \<noteq> a }\<close> show "a \<in> \<Union> { set (support p a) | a. p a \<noteq> a }"
+      by blast
   qed
 next
-  show "S \<subseteq> \<Union>{{(p ^^ k) x |k. 0 \<le> k} |x. x \<in> S}"
+  show "\<Union> { set (support p a) | a. p a \<noteq> a } \<subseteq> { a. p a \<noteq> a }"
   proof
-    fix x assume x: "x \<in> S"
-    hence "x \<in> {(p ^^ k) x |k. 0 \<le> k}"
-      by (metis (mono_tags, lifting) CollectI funpow_0 le_numeral_extra(3))
-    thus "x \<in> \<Union>{{(p ^^ k) x |k. 0 \<le> k} |x. x \<in> S}" using x by blast
+    fix b assume "b \<in> \<Union> { set (support p a) | a. p a \<noteq> a }"
+    then obtain a i where "p a \<noteq> a" and "(p ^^ i) a = b"
+      by auto
+    have "p a = a" if "(p ^^ i) a = (p ^^ Suc i) a"
+      using funpow_diff[OF bij_is_inj _ that] assms unfolding permutation by simp
+    with \<open>p a \<noteq> a\<close> and \<open>(p ^^ i) a = b\<close> show "b \<in> { a. p a \<noteq> a }"
+      by auto
   qed
 qed
 
 theorem cycle_restrict:
-  assumes "permutation p" "y \<in> set (support p x)"
-  shows "p y = (cycle_of_list (support p x)) y"
+  assumes "permutation p" and "b \<in> set (support p a)" shows "p b = (cycle_of_list (support p a)) b"
 proof -
-  have "\<And> i. \<lbrakk> 0 \<le> i; i < length (support p x) - 1 \<rbrakk> \<Longrightarrow>
-         p ((support p x) ! i) = (support p x) ! (i + 1)"
-  proof -
-    fix i assume i: "0 \<le> i" "i < length (support p x) - 1"
-    hence "p ((support p x) ! i) = p ((p ^^ i) x)" by simp
-    also have " ... = (p ^^ (i + 1)) x" by simp
-    also have " ... = (support p x) ! (i + 1)"
-      using i by simp
-    finally show "p ((support p x) ! i) = (support p x) ! (i + 1)" .
+  note least_power_props [simp] = least_power_of_permutation[OF assms(1)]
+
+  have "map (cycle_of_list (support p a)) (support p a) = rotate1 (support p a)"
+    using cyclic_rotation[OF cycle_of_permutation[OF assms(1)], of 1 a] by simp
+  hence "map (cycle_of_list (support p a)) (support p a) = tl (support p a) @ [ a ]"
+    by (simp add: hd_map rotate1_hd_tl)
+  also have " ... = map p (support p a)"
+  proof (rule nth_equalityI, auto)
+    fix i assume "i < least_power p a" show "(tl (support p a) @ [a]) ! i = p ((p ^^ i) a)"
+    proof (cases)
+      assume i: "i = least_power p a - 1"
+      hence "(tl (support p a) @ [ a ]) ! i = a"
+        by (metis (no_types, lifting) diff_zero length_map length_tl length_upt nth_append_length)
+      also have " ... = p ((p ^^ i) a)"
+        by (metis (mono_tags, hide_lams) least_power_props i Suc_diff_1 funpow_simps_right(2) funpow_swap1 o_apply)
+      finally show ?thesis .
+    next
+      assume "i \<noteq> least_power p a - 1"
+      with \<open>i < least_power p a\<close> have "i < least_power p a - 1"
+        by simp
+      hence "(tl (support p a) @ [ a ]) ! i = (p ^^ (Suc i)) a"
+        by (metis One_nat_def Suc_eq_plus1 add.commute length_map length_upt map_tl nth_append nth_map_upt tl_upt)
+      thus ?thesis
+        by simp
+    qed
   qed
-  hence 1: "map p (butlast (support p x)) = tl (support p x)"
-    using nth_butlast [where 'a='a] nth_tl [where 'a='a]
-      nth_equalityI[of "map p (butlast (support p x))" "tl (support p x)"] by force
-  have "p ((support p x) ! (length (support p x) - 1)) = p ((p ^^ (length (support p x) - 1)) x)"
+  finally have "map (cycle_of_list (support p a)) (support p a) = map p (support p a)" .
+  thus ?thesis
     using assms(2) by auto
-  also have " ... = (p ^^ (length (support p x))) x"
-    by (metis (mono_tags, lifting) Suc_pred' assms(2) funpow_Suc_right
-        funpow_swap1 length_pos_if_in_set o_apply)
-  also have " ... = x"
-    by (simp add: assms(1) least_power_wellfounded)
-  also have " ... = (support p x) ! 0"
-    by (simp add: assms(1) least_power_gt_zero)
-  finally have "p ((support p x) ! (length (support p x) - 1)) = (support p x) ! 0" .
-  hence 2: "p (last (support p x)) = hd (support p x)"
-    by (metis assms(2) hd_conv_nth last_conv_nth length_greater_0_conv length_pos_if_in_set)
-
-  have "map p (support p x) = (tl (support p x)) @ [hd (support p x)]" using 1 2
-    by (metis (no_types, lifting) assms(2) last_map length_greater_0_conv
-        length_pos_if_in_set list.map_disc_iff map_butlast snoc_eq_iff_butlast) 
-  hence "map p (support p x) = rotate1 (support p x)"
-    by (metis assms(2) length_greater_0_conv length_pos_if_in_set rotate1_hd_tl)
-
-  moreover have "map (cycle_of_list (support p x)) (support p x) = rotate1 (support p x)"
-    using cyclic_rotation[OF cycle_of_permutation[OF assms(1)], of 1 x] by simp
-
-  ultimately show ?thesis using assms(2)
-    using map_eq_conv by fastforce
 qed
 
 
 subsubsection\<open>Decomposition\<close>
 
-inductive cycle_decomp :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
-empty:  "cycle_decomp {} id" |
-comp: "\<lbrakk> cycle_decomp I p; cycle cs; set cs \<inter> I = {} \<rbrakk> \<Longrightarrow>
-         cycle_decomp (set cs \<union> I) ((cycle_of_list cs) \<circ> p)"
+inductive cycle_decomp :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
+  where
+    empty:  "cycle_decomp {} id"
+  | comp: "\<lbrakk> cycle_decomp I p; cycle cs; set cs \<inter> I = {} \<rbrakk> \<Longrightarrow>
+             cycle_decomp (set cs \<union> I) ((cycle_of_list cs) \<circ> p)"
 
 
 lemma semidecomposition:
-  assumes "p permutes S" "finite S"
-  shows "(\<lambda>y. if y \<in> (S - set (support p x)) then p y else y) permutes (S - set (support p x))"
-    (is "?q permutes ?S'")
-proof -
-  have "\<And>y. y \<notin> S \<Longrightarrow> p y = y"
-    by (meson assms permutes_not_in)
-
-  moreover have cycle_surj: "(cycle_of_list (support p x)) ` set (support p x) = set (support p x)"
-    using cycle_is_surj cycle_of_permutation assms permutation_permutes by metis
-  hence "\<And>y. y \<in> set (support p x) \<Longrightarrow> p y \<in> set (support p x)"
-    using cycle_restrict assms permutation_permutes by (metis imageI)
-
-  ultimately
-  have 1: "\<And>y. y \<notin> ?S' \<Longrightarrow> p y \<notin> ?S'" by auto
-  have 2: "\<And>y. y \<in> ?S' \<Longrightarrow> p y \<in> ?S'"
-  proof -
-    fix y assume y: "y \<in> ?S'" show "p y \<in> ?S'"
-    proof (rule ccontr)
-      assume "p y \<notin> ?S'" hence "p y \<in> set (support p x)"
-        using assms(1) permutes_in_image y by fastforce
-      then obtain y' where y': "y' \<in> set (support p x)" "(cycle_of_list (support p x)) y' = p y"
-        using cycle_surj by (metis (mono_tags, lifting) imageE)
-      hence "p y' = p y"
-        using cycle_restrict assms permutation_permutes by metis
-      hence "y = y'" by (metis assms(1) permutes_def)
-      thus False using y y' by blast
-    qed
-  qed
-  
-  have "p ` ?S' = ?S'"
-  proof -
-    have "\<And> y. y \<in> ?S' \<Longrightarrow> \<exists>!x. p x = y"
-      by (metis assms(1) permutes_def)
-    hence "\<And> y. y \<in> ?S' \<Longrightarrow> \<exists>x \<in> ?S'. p x = y" using 1 by metis
-    thus ?thesis using 2 by blast
-  qed
-  hence "bij_betw p ?S' ?S'"
-    by (metis DiffD1 assms(1) bij_betw_subset permutes_imp_bij subsetI)
-  hence "bij_betw ?q ?S' ?S'"
-    by (rule rev_iffD1 [OF _ bij_betw_cong]) auto
-  moreover have "\<And>y. y \<notin> ?S' \<Longrightarrow> ?q y = y" by auto
-  ultimately show ?thesis
-    using bij_imp_permutes by blast 
-qed
-
+  assumes "p permutes S" and "finite S"
+  shows "(\<lambda>y. if y \<in> (S - set (support p a)) then p y else y) permutes (S - set (support p a))"
+proof (rule bij_imp_permutes)
+  show "(if b \<in> (S - set (support p a)) then p b else b) = b" if "b \<notin> S - set (support p a)" for b
+    using that by auto
+next
+  have is_permutation: "permutation p"
+    using assms unfolding permutation_permutes by blast
 
-lemma cycle_decomposition_aux:
-  assumes "p permutes S" "finite S" "card S = k"
-  shows "cycle_decomp S p" using assms
-proof(induct arbitrary: S p rule: less_induct)
-  case (less x) thus ?case
-  proof (cases "S = {}")
-    case True thus ?thesis
-      by (metis empty less.prems(1) permutes_empty) 
+  let ?q = "\<lambda>y. if y \<in> (S - set (support p a)) then p y else y"
+  show "bij_betw ?q (S - set (support p a)) (S - set (support p a))"
+  proof (rule bij_betw_imageI)
+    show "inj_on ?q (S - set (support p a))"
+      using permutes_inj[OF assms(1)] unfolding inj_on_def by auto
   next
-    case False
-    then obtain x where x: "x \<in> S" by blast
-    define S' :: "'a set"   where S': "S' = S - set (support p x)"
-    define q  :: "'a \<Rightarrow> 'a" where  q: "q  = (\<lambda>x. if x \<in> S' then p x else x)"
-    hence q_permutes: "q permutes S'"
-      using semidecomposition[OF less.prems(1-2), of x] S' q by blast
-    moreover have "x \<in> set (support p x)"
-      by (metis (no_types, lifting) add.left_neutral diff_zero funpow_0 in_set_conv_nth least_power_gt_zero
-          length_map length_upt less.prems(1) less.prems(2) nth_map_upt permutation_permutes)
-    hence "card S' < card S"
-      by (metis Diff_iff S' \<open>x \<in> S\<close> card_seteq leI less.prems(2) subsetI)
-    ultimately have "cycle_decomp S' q"
-      using S' less.hyps less.prems(2) less.prems(3) by blast
-
-    moreover have "p = (cycle_of_list (support p x)) \<circ> q"
-    proof
-      fix y show "p y = ((cycle_of_list (support p x)) \<circ> q) y"
-      proof (cases)
-        assume y: "y \<in> set (support p x)" hence "y \<notin> S'" using S' by simp
-        hence "q y = y" using q by simp
-        thus ?thesis
-          using comp_apply cycle_restrict less.prems permutation_permutes y by fastforce
-      next
-        assume y: "y \<notin> set (support p x)" thus ?thesis
-        proof (cases)
-          assume "y \<in> S'"
-          hence "q y \<in> S'" using q_permutes
-            by (simp add: permutes_in_image)
-          hence "q y \<notin> set (support p x)"
-            using S' by blast
-          hence "(cycle_of_list (support p x)) (q y) = (q y)"
-            by (metis cycle_of_permutation id_outside_supp less.prems(1-2) permutation_permutes)
-          thus ?thesis by (simp add: \<open>y \<in> S'\<close> q)
-        next
-          assume "y \<notin> S'" hence "y \<notin> S" using y S' by blast
-          hence "(cycle_of_list (support p x) \<circ> q) y = (cycle_of_list (support p x)) y"
-            by (simp add: \<open>y \<notin> S'\<close> q)
-          also have " ... = y"
-            by (metis cycle_of_permutation id_outside_supp less.prems(1-2) permutation_permutes y)
-          also have " ... = p y"
-            by (metis \<open>y \<notin> S\<close> less.prems(1) permutes_def)
-          finally show ?thesis by simp
-        qed
-      qed
+    have aux_lemma: "set (support p s) \<subseteq> (S - set (support p a))" if "s \<in> S - set (support p a)" for s
+    proof -
+      have "(p ^^ i) s \<in> S" for i
+        using that unfolding permutes_in_image[OF permutes_funpow[OF assms(1)]] by simp
+      thus ?thesis
+        using that disjoint_support'[OF is_permutation, of s a] by auto
     qed
-    moreover have "cycle (support p x)"
-      using cycle_of_permutation less.prems permutation_permutes by fastforce
-    moreover have "set (support p x) \<inter> S' = {}" using S' by simp
-    moreover have "set (support p x) \<subseteq> S"
-      using support_coverture[OF less.prems(1-2)] support_set[of p x] x
-            permutation_permutes[of p] less.prems(1-2) by blast
-    hence "S = set (support p x) \<union> S'" using S' by blast 
-    ultimately show ?thesis using comp[of S' q "support p x"] by auto
+    have "(p ^^ 1) s \<in> set (support p s)" for s
+      unfolding support_set[OF is_permutation] by blast
+    hence "p s \<in> set (support p s)" for s
+      by simp
+    hence "p ` (S - set (support p a)) \<subseteq> S - set (support p a)"
+      using aux_lemma by blast
+    moreover have "(p ^^ ((least_power p s) - 1)) s \<in> set (support p s)" for s
+      unfolding support_set[OF is_permutation] by blast
+    hence "\<exists>s' \<in> set (support p s). p s' = s" for s
+      using least_power_of_permutation[OF is_permutation] by (metis Suc_diff_1 funpow.simps(2) o_apply)
+    hence "S - set (support p a) \<subseteq> p ` (S - set (support p a))"
+      using aux_lemma
+      by (clarsimp simp add: image_iff) (metis image_subset_iff)
+    ultimately show "?q ` (S - set (support p a)) = (S - set (support p a))"
+      by auto
   qed
 qed
 
 theorem cycle_decomposition:
-  assumes "p permutes S" "finite S"
-  shows "cycle_decomp S p"
-  using assms cycle_decomposition_aux by blast
+  assumes "p permutes S" and "finite S" shows "cycle_decomp S p"
+  using assms
+proof(induct "card S" arbitrary: S p rule: less_induct)
+  case less show ?case
+  proof (cases)
+    assume "S = {}" thus ?thesis
+      using empty less(2) by auto
+  next
+    have is_permutation: "permutation p"
+      using less(2-3) unfolding permutation_permutes by blast
+
+    assume "S \<noteq> {}" then obtain s where "s \<in> S"
+      by blast
+    define q where "q = (\<lambda>y. if y \<in> (S - set (support p s)) then p y else y)"
+    have "(cycle_of_list (support p s) \<circ> q) = p"
+    proof
+      fix a
+      consider "a \<in> S - set (support p s)" | "a \<in> set (support p s)" | "a \<notin> S" "a \<notin> set (support p s)"
+        by blast
+      thus "((cycle_of_list (support p s) \<circ> q)) a = p a"
+      proof cases
+        case 1
+        have "(p ^^ 1) a \<in> set (support p a)"
+          unfolding support_set[OF is_permutation] by blast
+        with \<open>a \<in> S - set (support p s)\<close> have "p a \<notin> set (support p s)"
+          using disjoint_support'[OF is_permutation, of a s] by auto
+        with \<open>a \<in> S - set (support p s)\<close> show ?thesis
+          using id_outside_supp[of _ "support p s"] unfolding q_def by simp
+      next
+        case 2 thus ?thesis
+          using cycle_restrict[OF is_permutation] unfolding q_def by simp
+      next
+        case 3 thus ?thesis
+          using id_outside_supp[OF 3(2)] less(2) permutes_not_in unfolding q_def by fastforce
+      qed
+    qed
+
+    moreover from \<open>s \<in> S\<close> have "(p ^^ i) s \<in> S" for i
+      unfolding permutes_in_image[OF permutes_funpow[OF less(2)]] .
+    hence "set (support p s) \<union> (S - set (support p s)) = S"
+      by auto
+
+    moreover have "s \<in> set (support p s)"
+      using least_power_of_permutation[OF is_permutation] by force
+    with \<open>s \<in> S\<close> have "card (S - set (support p s)) < card S"
+      using less(3) by (metis DiffE card_seteq linorder_not_le subsetI)
+    hence "cycle_decomp (S - set (support p s)) q"
+      using less(1)[OF _ semidecomposition[OF less(2-3)], of s] less(3) unfolding q_def by blast
+
+    moreover show ?thesis
+      using comp[OF calculation(3) cycle_of_permutation[OF is_permutation], of s]
+      unfolding calculation(1-2) by blast  
+  qed
+qed
 
 end
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Embedded_Algebras.thy
--- a/src/HOL/Algebra/Embedded_Algebras.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Embedded_Algebras.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -412,9 +412,6 @@
 lemma Span_eq_generate:
   assumes "set Us \<subseteq> carrier R" shows "Span K Us = generate (add_monoid R) (K <#> (set Us))"
 proof (rule add.generateI)
-  show "K <#> set Us \<subseteq> carrier R"
-    using subring_props(1) assms unfolding set_mult_def by blast
-next
   show "subgroup (Span K Us) (add_monoid R)"
     using Span_is_add_subgroup[OF assms] .
 next
@@ -474,8 +471,7 @@
 corollary mono_Span_sublist:
   assumes "set Us \<subseteq> set Vs" "set Vs \<subseteq> carrier R"
   shows "Span K Us \<subseteq> Span K Vs"
-  using add.mono_generate[OF mono_set_mult[OF _ assms(1), of K K R]
-        set_mult_closed[OF subring_props(1) assms(2)]]
+  using add.mono_generate[OF mono_set_mult[OF _ assms(1), of K K R]]
         Span_eq_generate[OF assms(2)] Span_eq_generate[of Us] assms by auto
 
 corollary mono_Span_append:
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Generated_Groups.thy
--- a/src/HOL/Algebra/Generated_Groups.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Generated_Groups.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -4,12 +4,12 @@
 
 theory Generated_Groups
   imports Group Coset
+  
 begin
 
-section\<open>Generated Groups\<close>
+section \<open>Generated Groups\<close>
 
-inductive_set
-  generate :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set"
+inductive_set generate :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set"
   for G and H where
     one:  "\<one>\<^bsub>G\<^esub> \<in> generate G H"
   | incl: "h \<in> H \<Longrightarrow> h \<in> generate G H"
@@ -17,624 +17,423 @@
   | eng:  "h1 \<in> generate G H \<Longrightarrow> h2 \<in> generate G H \<Longrightarrow> h1 \<otimes>\<^bsub>G\<^esub> h2 \<in> generate G H"
 
 
-subsection\<open>Basic Properties of Generated Groups - First Part\<close>
-
-lemma (in group) generate_in_carrier:
-  assumes "H \<subseteq> carrier G"
-  shows "h \<in> generate G H \<Longrightarrow> h \<in> carrier G"
-  apply (induction rule: generate.induct) using assms by blast+
-
-lemma (in group) generate_m_inv_closed:
-  assumes "H \<subseteq> carrier G"
-  shows "h \<in> generate G H \<Longrightarrow> (inv h) \<in> generate G H"
-proof (induction rule: generate.induct)
-  case one thus ?case by (simp add: generate.one)
-next
-  case (incl h) thus ?case using generate.inv[OF incl(1), of G] by simp
-next
-  case (inv h) thus ?case using assms generate.incl by fastforce
-next
-  case (eng h1 h2)
-  hence "inv (h1 \<otimes> h2) = (inv h2) \<otimes> (inv h1)"
-    by (meson assms generate_in_carrier group.inv_mult_group is_group)
-  thus ?case using generate.eng[OF eng(4) eng(3)] by simp
-qed
-
-lemma (in group) generate_is_subgroup:
-  assumes "H \<subseteq> carrier G"
-  shows "subgroup (generate G H) G"
-proof (intro subgroupI)
-  show "generate G H \<subseteq> carrier G" using generate_in_carrier[OF assms] by blast
-  show "generate G H \<noteq> {}"        using generate.one by auto
-  show "\<And>h. h \<in> generate G H \<Longrightarrow> inv h \<in> generate G H"
-    using generate_m_inv_closed[OF assms] by blast
-  show "\<And>h1 h2. \<lbrakk> h1 \<in> generate G H; h2 \<in> generate G H \<rbrakk> \<Longrightarrow> h1 \<otimes> h2 \<in> generate G H"
-    by (simp add: generate.eng)
-qed
-
-
-subsection\<open>Characterisations of Generated Groups\<close>
-
-lemma (in group) generate_min_subgroup1:
-  assumes "H \<subseteq> carrier G"
-    and "subgroup E G" "H \<subseteq> E"
-  shows "generate G H \<subseteq> E"
-proof
-  fix h show "h \<in> generate G H \<Longrightarrow> h \<in> E"
-  proof (induct rule: generate.induct)
-    case one  thus ?case using subgroup.one_closed[OF assms(2)] by simp
-    case incl thus ?case using assms(3) by blast
-    case inv  thus ?case using subgroup.m_inv_closed[OF assms(2)] assms(3) by blast
-  next
-    case eng thus ?case using subgroup.m_closed[OF assms(2)] by simp
-  qed
-qed
-
-lemma (in group) generateI:
-  assumes "H \<subseteq> carrier G"
-    and "subgroup E G" "H \<subseteq> E"
-    and "\<And>K. \<lbrakk> subgroup K G; H \<subseteq> K \<rbrakk> \<Longrightarrow> E \<subseteq> K"
-  shows "E = generate G H"
-proof
-  show "E \<subseteq> generate G H"
-    using assms generate_is_subgroup generate.incl by (metis subset_iff)
-  show "generate G H \<subseteq> E"
-    using generate_min_subgroup1[OF assms(1-3)] by simp
-qed
+subsection \<open>Basic Properties\<close>
 
-lemma (in group) generateE:
-  assumes "H \<subseteq> carrier G" and "E = generate G H"
-  shows "subgroup E G" and "H \<subseteq> E" and "\<And>K. \<lbrakk> subgroup K G; H \<subseteq> K \<rbrakk> \<Longrightarrow> E \<subseteq> K"
-proof -
-  show "subgroup E G" using assms generate_is_subgroup by simp
-  show "H \<subseteq> E" using assms(2) by (simp add: generate.incl subsetI)
-  show "\<And>K. subgroup K G \<Longrightarrow> H \<subseteq> K \<Longrightarrow> E \<subseteq> K"
-    using assms generate_min_subgroup1 by auto
-qed
-
-lemma (in group) generate_min_subgroup2:
-  assumes "H \<subseteq> carrier G"
-  shows "generate G H = \<Inter>{K. subgroup K G \<and> H \<subseteq> K}"
+lemma (in group) generate_consistent:
+  assumes "K \<subseteq> H" "subgroup H G" shows "generate (G \<lparr> carrier := H \<rparr>) K = generate G K"
 proof
-  have "subgroup (generate G H) G \<and> H \<subseteq> generate G H"
-    by (simp add: assms generateE(2) generate_is_subgroup)
-  thus "\<Inter>{K. subgroup K G \<and> H \<subseteq> K} \<subseteq> generate G H" by blast
+  show "generate (G \<lparr> carrier := H \<rparr>) K \<subseteq> generate G K"
+  proof
+    fix h assume "h \<in> generate (G \<lparr> carrier := H \<rparr>) K" thus "h \<in> generate G K"
+    proof (induction, simp add: one, simp_all add: incl[of _ K G] eng)
+      case inv thus ?case
+        using m_inv_consistent assms generate.inv[of _ K G] by auto
+    qed
+  qed
 next
-  have "\<And>K. subgroup K G \<and> H \<subseteq> K \<Longrightarrow> generate G H \<subseteq> K"
-    by (simp add: assms generate_min_subgroup1)
-  thus "generate G H \<subseteq> \<Inter>{K. subgroup K G \<and> H \<subseteq> K}" by blast
-qed
-
-
-subsection\<open>Representation of Elements from a Generated Group\<close>
-
-text\<open>We define a sort of syntax tree to allow induction arguments with elements of a generated group\<close>
-
-datatype 'a repr =
-  One | Inv "'a" | Leaf "'a" | Mult "'a repr" "'a repr"
-
-fun norm :: "('a, 'b) monoid_scheme \<Rightarrow> 'a repr \<Rightarrow> 'a"
-  where
-    "norm G (One) = \<one>\<^bsub>G\<^esub>"
-  | "norm G (Inv h) = (inv\<^bsub>G\<^esub> h)"
-  | "norm G (Leaf h) = h"
-  | "norm G (Mult h1 h2) = (norm G h1) \<otimes>\<^bsub>G\<^esub> (norm G h2)"
-
-fun elts :: "'a repr \<Rightarrow> 'a set"
-  where
-    "elts (One) = {}"
-  | "elts (Inv h) = { h }"
-  | "elts (Leaf h) = { h }"
-  | "elts (Mult h1 h2) = (elts h1) \<union> (elts h2)"
-
-lemma (in group) generate_repr_iff:
-  assumes "H \<subseteq> carrier G"
-  shows "(h \<in> generate G H) \<longleftrightarrow> (\<exists>r. (elts r) \<subseteq> H \<and> norm G r = h)"
-proof
-  show "h \<in> generate G H \<Longrightarrow> \<exists>r. (elts r) \<subseteq> H \<and> norm G r = h"
-  proof (induction rule: generate.induct)
-    case one thus ?case
-      using elts.simps(1) norm.simps(1)[of G] by fastforce
-  next
-    case (incl h)
-    hence "elts (Leaf h) \<subseteq> H \<and> norm G (Leaf h) = h" by simp
-    thus ?case by blast
-  next
-    case (inv h)
-    hence "elts (Inv h) \<subseteq> H \<and> norm G (Inv h) = inv h" by auto
-    thus ?case by blast
-  next
-    case (eng h1 h2)
-    then obtain r1 r2 where r1: "elts r1 \<subseteq> H" "norm G r1 = h1"
-                        and r2: "elts r2 \<subseteq> H" "norm G r2 = h2" by blast
-    hence "elts (Mult r1 r2) \<subseteq> H \<and> norm G (Mult r1 r2) = h1 \<otimes> h2" by simp
-    thus ?case by blast
-  qed
-
-  show "\<exists>r. elts r \<subseteq> H \<and> norm G r = h \<Longrightarrow> h \<in> generate G H"
-  proof -
-    assume "\<exists>r. elts r \<subseteq> H \<and> norm G r = h"
-    then obtain r where "elts r \<subseteq> H" "norm G r = h" by blast
-    thus "h \<in> generate G H"
-    proof (induction arbitrary: h rule: repr.induct)
-      case One thus ?case using generate.one by auto
-    next
-      case Inv thus ?case using generate.simps by force
-    next
-      case Leaf thus ?case using generate.simps by force
-    next
-      case Mult thus ?case using generate.eng by fastforce
+  show "generate G K \<subseteq> generate (G \<lparr> carrier := H \<rparr>) K"
+  proof
+    note gen_simps = one incl eng
+    fix h assume "h \<in> generate G K" thus "h \<in> generate (G \<lparr> carrier := H \<rparr>) K"
+      using gen_simps[where ?G = "G \<lparr> carrier := H \<rparr>"]
+    proof (induction, auto)
+      fix h assume "h \<in> K" thus "inv h \<in> generate (G \<lparr> carrier := H \<rparr>) K"
+        using m_inv_consistent assms generate.inv[of h K "G \<lparr> carrier := H \<rparr>"] by auto
     qed
   qed
 qed
 
-corollary (in group) generate_repr_set:
-  assumes "H \<subseteq> carrier G"
-  shows "generate G H = {norm G r | r. (elts r) \<subseteq> H}" (is "?A = ?B")
+lemma (in group) generate_in_carrier:
+  assumes "H \<subseteq> carrier G" and "h \<in> generate G H" shows "h \<in> carrier G"
+  using assms(2,1) by (induct h rule: generate.induct) (auto)
+
+lemma (in group) generate_incl:
+  assumes "H \<subseteq> carrier G" shows "generate G H \<subseteq> carrier G"
+  using generate_in_carrier[OF assms(1)] by auto
+
+lemma (in group) generate_m_inv_closed:
+  assumes "H \<subseteq> carrier G" and "h \<in> generate G H" shows "(inv h) \<in> generate G H"
+  using assms(2,1)
+proof (induction rule: generate.induct, auto simp add: one inv incl)
+  fix h1 h2
+  assume h1: "h1 \<in> generate G H" "inv h1 \<in> generate G H"
+     and h2: "h2 \<in> generate G H" "inv h2 \<in> generate G H"
+  hence "inv (h1 \<otimes> h2) = (inv h2) \<otimes> (inv h1)"
+    by (meson assms generate_in_carrier group.inv_mult_group is_group)
+  thus "inv (h1 \<otimes> h2) \<in> generate G H"
+    using generate.eng[OF h2(2) h1(2)] by simp
+qed
+
+lemma (in group) generate_is_subgroup:
+  assumes "H \<subseteq> carrier G" shows "subgroup (generate G H) G"
+  using subgroup.intro[OF generate_incl eng one generate_m_inv_closed] assms by auto
+
+lemma (in group) mono_generate:
+  assumes "K \<subseteq> H" shows "generate G K \<subseteq> generate G H"
 proof
-  show "?A \<subseteq> ?B"
-  proof
-    fix h assume "h \<in> generate G H" thus "h \<in> {norm G r |r. elts r \<subseteq> H}"
-      using generate_repr_iff[OF assms] by auto
-  qed
-next
-  show "?B \<subseteq> ?A"
-  proof
-    fix h assume "h \<in> {norm G r |r. elts r \<subseteq> H}" thus "h \<in> generate G H"
-      using generate_repr_iff[OF assms] by auto
+  fix h assume "h \<in> generate G K" thus "h \<in> generate G H"
+    using assms by (induction) (auto simp add: one incl inv eng)
+qed
+
+lemma (in group) generate_subgroup_incl:
+  assumes "K \<subseteq> H" "subgroup H G" shows "generate G K \<subseteq> H"
+  using group.generate_incl[OF subgroup_imp_group[OF assms(2)], of K] assms(1)
+  by (simp add: generate_consistent[OF assms])
+
+lemma (in group) generate_minimal:
+  assumes "H \<subseteq> carrier G" shows "generate G H = \<Inter> { H'. subgroup H' G \<and> H \<subseteq> H' }"
+  using generate_subgroup_incl generate_is_subgroup[OF assms] incl[of _ H] by blast
+
+lemma (in group) generateI:
+  assumes "subgroup E G" "H \<subseteq> E" and "\<And>K. \<lbrakk> subgroup K G; H \<subseteq> K \<rbrakk> \<Longrightarrow> E \<subseteq> K"
+  shows "E = generate G H"
+proof -
+  have subset: "H \<subseteq> carrier G"
+    using subgroup.subset assms by auto
+  show ?thesis
+    using assms unfolding generate_minimal[OF subset] by blast
+qed
+
+lemma (in group) normal_generateI:
+  assumes "H \<subseteq> carrier G" and "\<And>h g. \<lbrakk> h \<in> H; g \<in> carrier G \<rbrakk> \<Longrightarrow> g \<otimes> h \<otimes> (inv g) \<in> H"
+  shows "generate G H \<lhd> G"
+proof (rule normal_invI[OF generate_is_subgroup[OF assms(1)]])
+  fix g h assume g: "g \<in> carrier G" show "h \<in> generate G H \<Longrightarrow> g \<otimes> h \<otimes> (inv g) \<in> generate G H"
+  proof (induct h rule: generate.induct)
+    case one thus ?case
+      using g generate.one by auto
+  next
+    case incl show ?case
+      using generate.incl[OF assms(2)[OF incl g]] .
+  next
+    case (inv h)
+    hence h: "h \<in> carrier G"
+      using assms(1) by auto
+    hence "inv (g \<otimes> h \<otimes> (inv g)) = g \<otimes> (inv h) \<otimes> (inv g)"
+      using g by (simp add: inv_mult_group m_assoc)
+    thus ?case
+      using generate_m_inv_closed[OF assms(1) generate.incl[OF assms(2)[OF inv g]]] by simp
+  next
+    case (eng h1 h2)
+    note in_carrier = eng(1,3)[THEN generate_in_carrier[OF assms(1)]]
+    have "g \<otimes> (h1 \<otimes> h2) \<otimes> inv g = (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g)"
+      using in_carrier g by (simp add: inv_solve_left m_assoc)
+    thus ?case
+      using generate.eng[OF eng(2,4)] by simp
   qed
 qed
 
-corollary (in group) mono_generate:
-  assumes "I \<subseteq> J" and "J \<subseteq> carrier G"
-  shows "generate G I \<subseteq> generate G J"
-  using assms generate_repr_iff by fastforce
+lemma (in group) subgroup_int_pow_closed:
+  assumes "subgroup H G" "h \<in> H" shows "h [^] (k :: int) \<in> H"
+  using group.int_pow_closed[OF subgroup_imp_group[OF assms(1)]] assms(2)
+  unfolding int_pow_consistent[OF assms] by simp
 
-lemma (in group) subgroup_gen_equality:
-  assumes "subgroup H G" "K \<subseteq> H"
-  shows "generate G K = generate (G \<lparr> carrier := H \<rparr>) K"
-proof -
-  have "generate G K \<subseteq> H"
-    by (meson assms generate_min_subgroup1 order.trans subgroup.subset)
-  have mult_eq: "\<And>k1 k2. \<lbrakk> k1 \<in> generate G K; k2 \<in> generate G K \<rbrakk> \<Longrightarrow>
-                           k1 \<otimes>\<^bsub>G \<lparr> carrier := H \<rparr>\<^esub> k2 = k1 \<otimes> k2"
-    using \<open>generate G K \<subseteq> H\<close> subgroup_mult_equality by simp
-
-  { fix r assume A: "elts r \<subseteq> K"
-    hence "norm G r = norm (G \<lparr> carrier := H \<rparr>) r"
-    proof (induction r rule: repr.induct)
-      case One thus ?case by simp
-    next
-      case (Inv k) hence "k \<in> K" using A by simp
-      thus ?case using m_inv_consistent[OF assms(1)] assms(2) by auto
+lemma (in group) generate_pow:
+  assumes "a \<in> carrier G" shows "generate G { a } = { a [^] (k :: int) | k. k \<in> UNIV }"
+proof
+  show "{ a [^] (k :: int) | k. k \<in> UNIV } \<subseteq> generate G { a }"
+    using subgroup_int_pow_closed[OF generate_is_subgroup[of "{ a }"] incl[of a]] assms by auto
+next
+  show "generate G { a } \<subseteq> { a [^] (k :: int) | k. k \<in> UNIV }"
+  proof
+    fix h assume "h \<in> generate G { a }" hence "\<exists>k :: int. h = a [^] k"
+    proof (induction, metis int_pow_0[of a], metis singletonD int_pow_1[OF assms])
+      case (inv h)
+      hence "inv h = a [^] ((- 1) :: int)"
+        using assms unfolding int_pow_def2 by simp
+      thus ?case
+        by blast 
     next
-      case (Leaf k) hence "k \<in> K" using A by simp
-      thus ?case using m_inv_consistent[OF assms(1)] assms(2) by auto
-    next
-      case (Mult k1 k2) thus ?case using mult_eq by auto
-    qed } note aux_lemma = this
+      case eng thus ?case
+        using assms by (metis int_pow_mult)
+    qed
+    thus "h \<in> { a [^] (k :: int) | k. k \<in> UNIV }"
+      by blast
+  qed
+qed
+
+corollary (in group) generate_one: "generate G { \<one> } = { \<one> }"
+  using generate_pow[of "\<one>", OF one_closed] by simp
+
+corollary (in group) generate_empty: "generate G {} = { \<one> }"
+  using mono_generate[of "{}" "{ \<one> }"] generate.one unfolding generate_one by auto
 
-  show ?thesis
+lemma (in group_hom)
+  "subgroup K G \<Longrightarrow> subgroup (h ` K) H"
+  using subgroup_img_is_subgroup by auto
+
+lemma (in group_hom) generate_img:
+  assumes "K \<subseteq> carrier G" shows "generate H (h ` K) = h ` (generate G K)"
+proof
+  have "h ` K \<subseteq> h ` (generate G K)"
+    using incl[of _ K G] by auto
+  thus "generate H (h ` K) \<subseteq> h ` (generate G K)"
+    using generate_subgroup_incl subgroup_img_is_subgroup[OF G.generate_is_subgroup[OF assms]] by auto
+next
+  show "h ` (generate G K) \<subseteq> generate H (h ` K)"
   proof
-    show "generate G K \<subseteq> generate (G\<lparr>carrier := H\<rparr>) K"
-    proof
-      fix h assume "h \<in> generate G K" then obtain r where r: "elts r \<subseteq> K" "h = norm G r"
-        using generate_repr_iff assms by (metis order.trans subgroup.subset)
-      hence "h = norm (G \<lparr> carrier := H \<rparr>) r" using aux_lemma by simp
-      thus "h \<in> generate (G\<lparr>carrier := H\<rparr>) K"
-        using r assms group.generate_repr_iff [of "G \<lparr> carrier := H \<rparr>" K]
-              subgroup.subgroup_is_group[OF assms(1) is_group] by auto
-    qed
-    show "generate (G\<lparr>carrier := H\<rparr>) K \<subseteq> generate G K"
-    proof
-      fix h assume "h \<in> generate (G\<lparr>carrier := H\<rparr>) K"
-      then obtain r where r: "elts r \<subseteq> K" "h = norm (G\<lparr>carrier := H\<rparr>) r"
-        using group.generate_repr_iff [of "G \<lparr> carrier := H \<rparr>" K]
-              subgroup.subgroup_is_group[OF assms(1) is_group] assms by auto
-      hence "h = norm G r" using aux_lemma by simp
-      thus "h \<in> generate G K"
-        by (meson assms generate_repr_iff order.trans r(1) subgroup.subset)
+    fix a assume "a \<in> h ` (generate G K)"
+    then obtain k where "k \<in> generate G K" "a = h k"
+      by blast
+    show "a \<in> generate H (h ` K)"
+      using \<open>k \<in> generate G K\<close> unfolding \<open>a = h k\<close>
+    proof (induct k, auto simp add: generate.one[of H] generate.incl[of _ "h ` K" H])
+      case (inv k) show ?case
+        using assms generate.inv[of "h k" "h ` K" H] inv by auto  
+    next
+      case eng show ?case
+        using generate.eng[OF eng(2,4)] eng(1,3)[THEN G.generate_in_carrier[OF assms]] by auto
     qed
   qed
 qed
 
-corollary (in group) gen_equality_betw_subgroups:
-  assumes "subgroup I G" "subgroup J G" "K \<subseteq> (I \<inter> J)"
-  shows "generate (G \<lparr> carrier := I \<rparr>) K = generate (G \<lparr> carrier := J \<rparr>) K"
-  by (metis Int_subset_iff assms subgroup_gen_equality)
 
-lemma (in group) normal_generateI:
-  assumes "H \<subseteq> carrier G"
-    and "\<And>h g. \<lbrakk> h \<in> H; g \<in> carrier G \<rbrakk> \<Longrightarrow> g \<otimes> h \<otimes> (inv g) \<in> H"
-  shows "generate G H \<lhd> G"
-proof (rule normal_invI)
-  show "subgroup (generate G H) G"
-    by (simp add: assms(1) generate_is_subgroup)
-next
-  have "\<And>r g. \<lbrakk> elts r \<subseteq> H; g \<in> carrier G \<rbrakk> \<Longrightarrow> (g \<otimes> (norm G r) \<otimes> (inv g)) \<in> (generate G H)"
-  proof -
-    fix r g assume "elts r \<subseteq> H" "g \<in> carrier G"
-    thus "(g \<otimes> (norm G r) \<otimes> (inv g)) \<in> (generate G H)"
-    proof (induction r rule: repr.induct)
-      case One thus ?case
-        by (simp add: generate.one)
-    next
-      case (Inv h)
-      hence "g \<otimes> h \<otimes> (inv g) \<in> H" using assms(2) by simp
-      moreover have "norm G (Inv (g \<otimes> h \<otimes> (inv g))) = g \<otimes> (inv h) \<otimes> (inv g)"
-        using Inv.prems(1) Inv.prems(2) assms(1) inv_mult_group m_assoc by auto
-      ultimately have "\<exists>r. elts r \<subseteq> H \<and> norm G r = g \<otimes> (inv h) \<otimes> (inv g)"
-        by (metis elts.simps(2) empty_subsetI insert_subset)
-      thus ?case by (simp add: assms(1) generate_repr_iff)
-    next
-      case (Leaf h)
-      thus ?case using assms(2)[of h g] generate.incl[of "g \<otimes> h \<otimes> inv g" H] by simp
-    next
-      case (Mult h1 h2)
-      hence "elts h1 \<subseteq> H \<and> elts h2 \<subseteq> H" using Mult(3) by simp
-      hence in_gen: "norm G h1 \<in> generate G H \<and> norm G h2 \<in> generate G H"
-        using assms(1) generate_repr_iff by auto
-
-      have "g \<otimes> norm G (Mult h1 h2) \<otimes> inv g = g \<otimes> (norm G h1 \<otimes> norm G h2) \<otimes> inv g" by simp
-      also have " ... = g \<otimes> (norm G h1 \<otimes> (inv g \<otimes> g) \<otimes> norm G h2) \<otimes> inv g"
-        using Mult(4) in_gen assms(1) generate_in_carrier by auto
-      also have " ... = (g \<otimes> norm G h1 \<otimes> inv g) \<otimes> (g \<otimes> norm G h2 \<otimes> inv g)"
-        using Mult.prems(2) assms(1) generate_in_carrier in_gen inv_closed m_assoc m_closed by presburger
-      finally have "g \<otimes> norm G (Mult h1 h2) \<otimes> inv g =
-                   (g \<otimes> norm G h1 \<otimes> inv g) \<otimes> (g \<otimes> norm G h2 \<otimes> inv g)" .
-
-      thus ?case
-        using generate.eng[of "g \<otimes> norm G h1 \<otimes> inv g" G H "g \<otimes> norm G h2 \<otimes> inv g"]
-        by (simp add: Mult.IH Mult.prems(2) \<open>elts h1 \<subseteq> H \<and> elts h2 \<subseteq> H\<close>)
-    qed
-  qed
-  thus "\<And>x h. x \<in> carrier G \<Longrightarrow> h \<in> generate G H \<Longrightarrow> x \<otimes> h \<otimes> inv x \<in> generate G H"
-    using assms(1) generate_repr_iff by auto
-qed
-
-
-subsection\<open>Basic Properties of Generated Groups - Second Part\<close>
+section \<open>Derived Subgroup\<close>
 
-lemma (in group) generate_pow:
-  assumes "a \<in> carrier G"
-  shows "generate G { a } = range (\<lambda>k::int. a [^] k)" (is "?lhs = ?rhs")
-proof
-  show "?lhs \<subseteq> ?rhs"
-  proof
-    fix h  show "h \<in> generate G { a } \<Longrightarrow> h \<in> range (\<lambda>k::int. a [^] k)"
-    proof (induction rule: generate.induct)
-      case one thus ?case
-        by (metis (full_types) int_pow_0 rangeI) 
-    next
-      case (incl h) hence "h = a" by auto thus ?case
-        by (metis \<open>h = a\<close> assms group.int_pow_1 is_group rangeI)
-    next
-      case (inv h) hence "h = a" by auto thus ?case
-        by (metis (mono_tags) rangeI assms group.int_pow_1 int_pow_neg is_group)
-    next
-      case (eng h1 h2) thus ?case
-        using assms is_group   by (auto simp: image_iff simp flip: int_pow_mult)
-    qed
-  qed
+subsection \<open>Definitions\<close>
 
-  show "?rhs \<subseteq> ?lhs"
-  proof
-    { fix k :: "nat" have "a [^] k \<in> generate G { a }"
-      proof (induction k)
-        case 0 thus ?case by (simp add: generate.one)
-      next
-        case (Suc k) thus ?case by (simp add: generate.eng generate.incl)
-      qed } note aux_lemma = this
-
-    fix h assume "h \<in> ?rhs"
-    then obtain k :: "nat" where "h = a [^] k \<or> h = inv (a [^] k)"
-      by (auto simp: int_pow_def2)
-    thus "h \<in> generate G { a }" using aux_lemma
-      using assms generate_m_inv_closed by auto
-  qed
-qed
-
-(*  { a [^] k | k. k \<in> (UNIV :: int set) } *)
-
-corollary (in group) generate_one: "generate G { \<one> } = { \<one> }"
-  using generate_pow[of "\<one>", OF one_closed] by auto
-
-corollary (in group) generate_empty: "generate G {} = { \<one> }"
-  using mono_generate[of "{}" "{ \<one> }"] generate_one generate.one one_closed by blast
-
-corollary (in group)
-  assumes "H \<subseteq> carrier G" "h \<in> H"
-  shows "h [^] (k :: int) \<in> generate G H"
-  using mono_generate[of "{ h }" H] generate_pow[of h] assms by auto
-
-
-subsection\<open>Derived Subgroup\<close>
-
-abbreviation derived_set :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set" where
-  "derived_set G H \<equiv>
-     \<Union>h1 \<in> H. (\<Union>h2 \<in> H. { h1 \<otimes>\<^bsub>G\<^esub> h2 \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> h1) \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> h2) })"
+abbreviation derived_set :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set"
+  where "derived_set G H \<equiv>
+           \<Union>h1 \<in> H. (\<Union>h2 \<in> H. { h1 \<otimes>\<^bsub>G\<^esub> h2 \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> h1) \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> h2) })"
 
 definition derived :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set" where
   "derived G H = generate G (derived_set G H)"
 
+
+subsection \<open>Basic Properties\<close>
+
 lemma (in group) derived_set_incl:
-  assumes "subgroup H G"
-  shows "derived_set G H \<subseteq> H"
-  by (auto simp add: m_inv_consistent[OF assms] subgroupE[OF assms])
+  assumes "K \<subseteq> H" "subgroup H G" shows "derived_set G K \<subseteq> H"
+  using assms(1) subgroupE(3-4)[OF assms(2)] by (auto simp add: subset_iff)
 
 lemma (in group) derived_incl:
-  assumes "subgroup H G"
-  shows "derived G H \<subseteq> H"
-  unfolding derived_def using derived_set_incl[OF assms] assms
-  by (meson generate_min_subgroup1 order.trans subgroup.subset)
-
-lemma (in group) subgroup_derived_equality:
-  assumes "subgroup H G" "K \<subseteq> H"
-  shows "derived (G \<lparr> carrier := H \<rparr>) K = derived G K"
-proof -
-  have "derived_set G K \<subseteq> H"
-  proof
-    fix x assume "x \<in> derived_set G K"
-    then obtain k1 k2
-      where k12: "k1 \<in> K" "k2 \<in> K"
-        and  "x = k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2" by blast
-    thus "x \<in> H" using k12 assms by (meson subgroup_def subsetCE)
-  qed
-
-  moreover have "derived_set (G \<lparr> carrier := H \<rparr>) K = derived_set G K"
-  proof
-    show "derived_set G K \<subseteq> derived_set (G\<lparr>carrier := H\<rparr>) K"
-    proof
-      fix x assume "x \<in> derived_set G K"
-      then obtain k1 k2 where k12: "k1 \<in> K" "k2 \<in> K"
-                          and "x = k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2" by blast
-      hence "x = k1 \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> k2 \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> inv\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> k1 \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> inv\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> k2"
-        using subgroup_mult_equality[OF assms(1)] m_inv_consistent[OF assms(1)] assms(2) k12
-        by (simp add: subset_iff)
-      thus "x \<in> derived_set (G\<lparr>carrier := H\<rparr>) K" using k12 by blast
-    qed
-  next
-    show "derived_set (G \<lparr> carrier := H \<rparr>) K \<subseteq> derived_set G K"
-    proof
-      fix x assume "x \<in> derived_set (G \<lparr> carrier := H \<rparr>) K"
-      then obtain k1 k2
-        where k12: "k1 \<in> K" "k2 \<in> K"
-          and "x = k1 \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> k2 \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> inv\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> k1 \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> inv\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> k2"
-        by blast
-      hence "x = k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2"
-        using subgroup_mult_equality[OF assms(1)] m_inv_consistent[OF assms(1)] assms(2) k12
-        by (simp add: subset_iff)
-      thus "x \<in> derived_set G K" using k12 assms by blast
-    qed
-  qed
-
-  ultimately show ?thesis unfolding derived_def
-    using subgroup_gen_equality[OF assms(1), of "derived_set (G\<lparr>carrier := H\<rparr>) K"] by simp
-qed
-
-lemma (in comm_group) derived_set:
-  assumes "H \<subseteq> carrier G"
-  shows "derived G H = { \<one> }"
-proof -
-  have "derived_set G H = {} \<or> derived_set G H = { \<one> }"
-  proof (cases)
-    assume "H = {}" thus ?thesis by simp
-  next
-    assume "H \<noteq> {}" then obtain h' where h': "h' \<in> H" by blast
-    have "derived_set G H = { \<one> }"
-    proof -
-      { fix h assume A: "h \<in> derived_set G H"
-        have "h = \<one>"
-        proof -
-          obtain h1 h2 where h1: "h1 \<in> H" and h2: "h2 \<in> H" and h: "h = h1 \<otimes> h2 \<otimes> inv h1 \<otimes> inv h2"
-            using A by blast
-          then have "h1 \<in> carrier G" "h2 \<in> carrier G"
-            using assms by auto
-          then have "\<one> = h"
-            by (metis \<open>h1 \<in> carrier G\<close> \<open>h2 \<in> carrier G\<close> h inv_closed inv_mult m_assoc m_closed r_inv)
-          then show ?thesis
-            using \<open>h1 \<in> carrier G\<close> \<open>h2 \<in> carrier G\<close> by force
-        qed } note aux_lemma = this
-      show ?thesis
-      proof
-        show "derived_set G H \<subseteq> { \<one> }" using aux_lemma by blast
-      next
-        show "{ \<one> } \<subseteq> derived_set G H"
-        proof -
-          have "h' \<otimes> h' \<otimes> inv h' \<otimes> inv h' \<in> derived_set G H" using h' by blast
-          thus ?thesis using aux_lemma by auto
-        qed
-      qed
-    qed
-    thus ?thesis by simp
-  qed
-  thus ?thesis unfolding derived_def using generate_empty generate_one by presburger
-qed
+  assumes "K \<subseteq> H" "subgroup H G" shows "derived G K \<subseteq> H"
+  using generate_subgroup_incl[OF derived_set_incl] assms unfolding derived_def by auto
 
 lemma (in group) derived_set_in_carrier:
-  assumes "H \<subseteq> carrier G"
-  shows "derived_set G H \<subseteq> carrier G"
-proof
-  fix h assume "h \<in> derived_set G H"
-  then obtain h1 h2 where "h1 \<in> H" "h2 \<in> H" "h = h1 \<otimes> h2 \<otimes> inv h1 \<otimes> inv h2"
-    by blast
-  thus "h \<in> carrier G" using assms by blast
+  assumes "H \<subseteq> carrier G" shows "derived_set G H \<subseteq> carrier G"
+  using derived_set_incl[OF assms subgroup_self] .
+
+lemma (in group) derived_in_carrier:
+  assumes "H \<subseteq> carrier G" shows "derived G H \<subseteq> carrier G"
+  using derived_incl[OF assms subgroup_self] .
+
+lemma (in group) exp_of_derived_in_carrier:
+  assumes "H \<subseteq> carrier G" shows "(derived G ^^ n) H \<subseteq> carrier G"
+  using assms derived_in_carrier by (induct n) (auto)
+
+lemma (in group) derived_is_subgroup:
+  assumes "H \<subseteq> carrier G" shows "subgroup (derived G H) G"
+  unfolding derived_def using generate_is_subgroup[OF derived_set_in_carrier[OF assms]] .
+
+lemma (in group) exp_of_derived_is_subgroup:
+  assumes "subgroup H G" shows "subgroup ((derived G ^^ n) H) G"
+  using assms derived_is_subgroup subgroup.subset by (induct n) (auto)
+
+lemma (in group) exp_of_derived_is_subgroup':
+  assumes "H \<subseteq> carrier G" shows "subgroup ((derived G ^^ (Suc n)) H) G"
+  using assms derived_is_subgroup[OF subgroup.subset] derived_is_subgroup by (induct n) (auto)
+
+lemma (in group) mono_derived_set:
+  assumes "K \<subseteq> H" shows "derived_set G K \<subseteq> derived_set G H"
+  using assms by auto
+
+lemma (in group) mono_derived:
+  assumes "K \<subseteq> H" shows "derived G K \<subseteq> derived G H"
+  unfolding derived_def using mono_generate[OF mono_derived_set[OF assms]] .
+
+lemma (in group) mono_exp_of_derived:
+  assumes "K \<subseteq> H" shows "(derived G ^^ n) K \<subseteq> (derived G ^^ n) H"
+  using assms mono_derived by (induct n) (auto)
+
+lemma (in group) derived_set_consistent:
+  assumes "K \<subseteq> H" "subgroup H G" shows "derived_set (G \<lparr> carrier := H \<rparr>) K = derived_set G K"
+  using m_inv_consistent[OF assms(2)] assms(1) by (auto simp add: subset_iff)
+
+lemma (in group) derived_consistent:
+  assumes "K \<subseteq> H" "subgroup H G" shows "derived (G \<lparr> carrier := H \<rparr>) K = derived G K"
+  using generate_consistent[OF derived_set_incl] derived_set_consistent assms by (simp add: derived_def)
+
+lemma (in comm_group) derived_eq_singleton:
+  assumes "H \<subseteq> carrier G" shows "derived G H = { \<one> }"
+proof (cases "derived_set G H = {}")
+  case True show ?thesis
+    using generate_empty unfolding derived_def True by simp
+next
+  case False
+  have aux_lemma: "h \<in> derived_set G H \<Longrightarrow> h = \<one>" for h
+    using assms by (auto simp add: subset_iff)
+       (metis (no_types, lifting) m_comm m_closed inv_closed inv_solve_right l_inv l_inv_ex)
+  have "derived_set G H = { \<one> }"
+  proof
+    show "derived_set G H \<subseteq> { \<one> }"
+      using aux_lemma by auto
+  next
+    obtain h where h: "h \<in> derived_set G H"
+      using False by blast
+    thus "{ \<one> } \<subseteq> derived_set G H"
+      using aux_lemma[OF h] by auto
+  qed
+  thus ?thesis
+    using generate_one unfolding derived_def by auto
 qed
 
 lemma (in group) derived_is_normal:
-  assumes "H \<lhd> G"
-  shows "derived G H \<lhd> G" unfolding derived_def
-proof (rule normal_generateI)
-  show "(\<Union>h1 \<in> H. \<Union>h2 \<in> H. { h1 \<otimes> h2 \<otimes> inv h1 \<otimes> inv h2 }) \<subseteq> carrier G"
-    using subgroup.subset assms normal_imp_subgroup by blast
-next
-  show "\<And>h g. \<lbrakk> h \<in> derived_set G H; g \<in> carrier G \<rbrakk> \<Longrightarrow> g \<otimes> h \<otimes> inv g \<in> derived_set G H"
-  proof -
+  assumes "H \<lhd> G" shows "derived G H \<lhd> G"
+proof -
+  interpret H: normal H G
+    using assms .
+
+  show ?thesis
+    unfolding derived_def
+  proof (rule normal_generateI[OF derived_set_in_carrier[OF H.subset]])
     fix h g assume "h \<in> derived_set G H" and g: "g \<in> carrier G"
-    then obtain h1 h2 where h1: "h1 \<in> H" "h1 \<in> carrier G"
-                        and h2: "h2 \<in> H" "h2 \<in> carrier G"
-                        and h:  "h = h1 \<otimes> h2 \<otimes> inv h1 \<otimes> inv h2"
-      using subgroup.subset assms normal_imp_subgroup by blast
-    hence "g \<otimes> h \<otimes> inv g =
+    then obtain h1 h2 where h: "h1 \<in> H" "h2 \<in> H" "h = h1 \<otimes> h2 \<otimes> inv h1 \<otimes> inv h2"
+      by auto
+    hence in_carrier: "h1 \<in> carrier G" "h2 \<in> carrier G" "g \<in> carrier G"
+      using H.subset g by auto
+    have "g \<otimes> h \<otimes> inv g =
            g \<otimes> h1 \<otimes> (inv g \<otimes> g) \<otimes> h2 \<otimes> (inv g \<otimes> g) \<otimes> inv h1 \<otimes> (inv g \<otimes> g) \<otimes> inv h2 \<otimes> inv g"
-      by (simp add: g m_assoc)
-    also
-    have " ... =
+      unfolding h(3) by (simp add: in_carrier m_assoc)
+    also have " ... =
           (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g) \<otimes> (g \<otimes> inv h1 \<otimes> inv g) \<otimes> (g \<otimes> inv h2 \<otimes> inv g)"
-      using g h1 h2 m_assoc inv_closed m_closed by presburger
-    finally
-    have "g \<otimes> h \<otimes> inv g =
-         (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g) \<otimes> inv (g \<otimes> h1 \<otimes> inv g) \<otimes> inv (g \<otimes> h2 \<otimes> inv g)"
-      by (simp add: g h1 h2 inv_mult_group m_assoc)
-    moreover have "g \<otimes> h1 \<otimes> inv g \<in> H" by (simp add: assms normal.inv_op_closed2 g h1)
-    moreover have "g \<otimes> h2 \<otimes> inv g \<in> H" by (simp add: assms normal.inv_op_closed2 g h2)
-    ultimately show "g \<otimes> h \<otimes> inv g \<in> derived_set G H" by blast
+      using in_carrier m_assoc inv_closed m_closed by presburger
+    finally have "g \<otimes> h \<otimes> inv g =
+          (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g) \<otimes> inv (g \<otimes> h1 \<otimes> inv g) \<otimes> inv (g \<otimes> h2 \<otimes> inv g)"
+      by (simp add: in_carrier inv_mult_group m_assoc)
+    thus "g \<otimes> h \<otimes> inv g \<in> derived_set G H"
+      using h(1-2)[THEN H.inv_op_closed2[OF g]] by auto
   qed
 qed
 
+lemma (in group) normal_self: "carrier G \<lhd> G"
+  by (rule normal_invI[OF subgroup_self], simp)
+
 corollary (in group) derived_self_is_normal: "derived G (carrier G) \<lhd> G"
-  by (simp add: group.derived_is_normal group.normal_invI is_group subgroup_self)
+  using derived_is_normal[OF normal_self] .
 
 corollary (in group) derived_subgroup_is_normal:
-  assumes "subgroup H G"
-  shows "derived G H \<lhd> G \<lparr> carrier := H \<rparr>"
-proof -
-  have "H \<lhd> G \<lparr> carrier := H \<rparr>"
-    by (metis assms group.coset_join3 group.normalI group.subgroup_self
-        partial_object.cases_scheme partial_object.select_convs(1) partial_object.update_convs(1)
-        subgroup.rcos_const subgroup_imp_group)
-  hence "derived (G \<lparr> carrier := H \<rparr>) H \<lhd> G \<lparr> carrier :=  H \<rparr>"
-    using group.derived_is_normal[of "G \<lparr> carrier := H \<rparr>" H] normal_def by blast
-  thus ?thesis using subgroup_derived_equality[OF assms] by simp
-qed
+  assumes "subgroup H G" shows "derived G H \<lhd> G \<lparr> carrier := H \<rparr>"
+  using group.derived_self_is_normal[OF subgroup_imp_group[OF assms]]
+        derived_consistent[OF _ assms]
+  by simp
 
 corollary (in group) derived_quot_is_group: "group (G Mod (derived G (carrier G)))"
-  using derived_self_is_normal normal.factorgroup_is_group by auto
+  using normal.factorgroup_is_group[OF derived_self_is_normal] by auto
+
+lemma (in group) derived_quot_is_comm_group: "comm_group (G Mod (derived G (carrier G)))"
+proof (rule group.group_comm_groupI[OF derived_quot_is_group], simp add: FactGroup_def)
+  interpret DG: normal "derived G (carrier G)" G
+    using derived_self_is_normal .
 
-lemma (in group) derived_quot_is_comm:
-  assumes "H \<in> carrier (G Mod (derived G (carrier G)))"
-    and "K \<in> carrier (G Mod (derived G (carrier G)))"
-  shows "H <#> K = K <#> H"
-proof -
-  { fix H K assume A1: "H \<in> carrier (G Mod (derived G (carrier G)))"
-               and A2: "K \<in> carrier (G Mod (derived G (carrier G)))"
-    have "H <#> K \<subseteq> K <#> H"
-    proof -
-      obtain h k where hk: "h \<in> carrier G" "k \<in> carrier G"
-                   and  H: "H = (derived G (carrier G)) #> h"
-                   and  K: "K = (derived G (carrier G)) #> k"
-        using A1 A2 unfolding FactGroup_def RCOSETS_def by auto
-      have "H <#> K = (h \<otimes> k) <# (derived G (carrier G))"
-        using hk H K derived_self_is_normal m_closed normal.coset_eq normal.rcos_sum
-        by (metis (no_types, lifting))
-      moreover have "K <#> H = (k \<otimes> h) <# (derived G (carrier G))"
-        using hk H K derived_self_is_normal m_closed normal.coset_eq normal.rcos_sum
-        by (metis (no_types, lifting))
-      moreover have "(h \<otimes> k) <# (derived G (carrier G)) \<subseteq> (k \<otimes> h) <# (derived G (carrier G))"
+  fix H K assume "H \<in> rcosets derived G (carrier G)" and "K \<in> rcosets derived G (carrier G)"
+  then obtain g1 g2
+    where g1: "g1 \<in> carrier G" "H = derived G (carrier G) #> g1"
+      and g2: "g2 \<in> carrier G" "K = derived G (carrier G) #> g2"
+    unfolding RCOSETS_def by auto
+  hence "H <#> K = derived G (carrier G) #> (g1 \<otimes> g2)"
+    by (simp add: DG.rcos_sum)
+  also have " ... = derived G (carrier G) #> (g2 \<otimes> g1)"
+  proof -
+    { fix g1 g2 assume g1: "g1 \<in> carrier G" and g2: "g2 \<in> carrier G"
+      have "derived G (carrier G) #> (g1 \<otimes> g2) \<subseteq> derived G (carrier G) #> (g2 \<otimes> g1)"
       proof
-        fix x assume "x \<in> h \<otimes> k <# derived G (carrier G)"
-        then obtain d where d: "d \<in> derived G (carrier G)" "d \<in> carrier G" "x = h \<otimes> k \<otimes> d"
-          using generate_is_subgroup[of "derived_set G (carrier G)"]
-                subgroup.subset[of "derived G (carrier G)" G]
-                derived_set_in_carrier[of "carrier G"]
-          unfolding l_coset_def derived_def by auto
-        hence "x = (k \<otimes> (h \<otimes> inv h) \<otimes> inv k) \<otimes> h \<otimes> k \<otimes> d"
-          using hk by simp
-        also have " ... = (k \<otimes> h) \<otimes> (inv h \<otimes> inv k) \<otimes> h \<otimes> k \<otimes> d"
-          using d(2) hk m_assoc by (metis subgroup_def subgroup_self)
-        also have " ... = (k \<otimes> h) \<otimes> ((inv h \<otimes> inv k \<otimes> h \<otimes> k) \<otimes> d)"
-          using d(2) hk m_assoc by simp
-        finally have "x = (k \<otimes> h) \<otimes> ((inv h \<otimes> inv k \<otimes> h \<otimes> k) \<otimes> d)" .
-
-        moreover have "inv h \<otimes> inv k \<otimes> inv (inv h) \<otimes> inv (inv k) \<in> derived_set G (carrier G)"
-          using inv_closed[OF hk(1)] inv_closed[OF hk(2)] by blast
-        hence "inv h \<otimes> inv k \<otimes> h \<otimes> k \<in> derived_set G (carrier G)"
-          by (simp add: hk(1) hk(2))
-        hence "(inv h \<otimes> inv k \<otimes> h \<otimes> k) \<otimes> d \<in> derived G (carrier G)"
-          using d(1) unfolding derived_def by (simp add: generate.eng generate.incl)
-
-        ultimately show "x \<in> (k \<otimes> h) <# (derived G (carrier G))"
-          unfolding l_coset_def by blast
-      qed
-      ultimately show ?thesis by simp
-    qed }
-  thus ?thesis using assms by auto
+        fix h assume "h \<in> derived G (carrier G) #> (g1 \<otimes> g2)"
+        then obtain g' where h: "g' \<in> carrier G" "g' \<in> derived G (carrier G)" "h = g' \<otimes> (g1 \<otimes> g2)"
+          using DG.subset unfolding r_coset_def by auto
+        hence "h = g' \<otimes> (g1 \<otimes> g2) \<otimes> (inv g1 \<otimes> inv g2 \<otimes> g2 \<otimes> g1)"
+          using g1 g2 by (simp add: m_assoc)
+        hence "h = (g' \<otimes> (g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2)) \<otimes> (g2 \<otimes> g1)"
+          using h(1) g1 g2 inv_closed m_assoc m_closed by presburger
+        moreover have "g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2 \<in> derived G (carrier G)"
+          using incl[of _ "derived_set G (carrier G)"] g1 g2 unfolding derived_def by blast
+        hence "g' \<otimes> (g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2) \<in> derived G (carrier G)"
+          using DG.m_closed[OF h(2)] by simp
+        ultimately show "h \<in> derived G (carrier G) #> (g2 \<otimes> g1)"
+          unfolding r_coset_def by blast
+      qed }
+    thus ?thesis
+      using g1(1) g2(1) by auto
+  qed
+  also have " ... = K <#> H"
+    by (simp add: g1 g2 DG.rcos_sum)
+  finally show "H <#> K = K <#> H" .
 qed
 
-theorem (in group) derived_quot_is_comm_group:
-  "comm_group (G Mod (derived G (carrier G)))"
-  apply (intro group.group_comm_groupI[OF derived_quot_is_group])
-  using derived_quot_is_comm by simp
-
 corollary (in group) derived_quot_of_subgroup_is_comm_group:
-  assumes "subgroup H G"
-  shows "comm_group ((G \<lparr> carrier := H \<rparr>) Mod (derived G H))"
-proof -
-  have "group (G \<lparr> carrier := H \<rparr>)"
-    using assms subgroup_imp_group by auto
-  thus ?thesis
-    using group.derived_quot_is_comm_group subgroup_derived_equality[OF assms] by fastforce
-qed
+  assumes "subgroup H G" shows "comm_group ((G \<lparr> carrier := H \<rparr>) Mod (derived G H))"
+  using group.derived_quot_is_comm_group[OF subgroup_imp_group[OF assms]]
+        derived_consistent[OF _ assms]
+  by simp
 
-lemma (in group) mono_derived:
-  assumes "J \<subseteq> carrier G" "I \<subseteq> J"
-  shows "(derived G ^^ n) I \<subseteq> (derived G ^^ n) J"
+proposition (in group) derived_minimal:
+  assumes "H \<lhd> G" and "comm_group (G Mod H)" shows "derived G (carrier G) \<subseteq> H"
 proof -
-  { fix I J assume A: "J \<subseteq> carrier G" "I \<subseteq> J" have "derived G I \<subseteq> derived G J"
-    proof -
-      have "derived_set G I \<subseteq> derived_set G J" using A by blast
-      thus ?thesis unfolding derived_def using mono_generate A by (simp add: derived_set_in_carrier)
-    qed } note aux_lemma1 = this
-
-  { fix n I assume A: "I \<subseteq> carrier G" have "(derived G ^^ n) I \<subseteq> carrier G"
-    proof (induction n)
-      case 0 thus ?case using A by simp
-    next
-      case (Suc n)
-      with aux_lemma1 have "(derived G ^^ Suc n) I \<subseteq> derived G (carrier G)"
-        by auto
-      also have "... \<subseteq> carrier G"
-        by (simp add: derived_incl subgroup_self)
-      finally show ?case .
-    qed } note aux_lemma2 = this
+  interpret H: normal H G
+    using assms(1) .
 
   show ?thesis
-  proof (induction n)
-    case 0 thus ?case using assms by simp
-  next
-    case (Suc n) thus ?case using aux_lemma1 aux_lemma2 assms(1) by auto
+    unfolding derived_def
+  proof (rule generate_subgroup_incl[OF _ H.subgroup_axioms])
+    show "derived_set G (carrier G) \<subseteq> H"
+    proof
+      fix h assume "h \<in> derived_set G (carrier G)"
+      then obtain g1 g2 where h: "g1 \<in> carrier G" "g2 \<in> carrier G" "h = g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2"
+        by auto
+      have "H #> (g1 \<otimes> g2) = (H #> g1) <#> (H #> g2)"
+        by (simp add: h(1-2) H.rcos_sum)
+      also have " ... = (H #> g2) <#> (H #> g1)"
+        using comm_groupE(4)[OF assms(2)] h(1-2) unfolding FactGroup_def RCOSETS_def by auto
+      also have " ... = H #> (g2 \<otimes> g1)"
+        by (simp add: h(1-2) H.rcos_sum)
+      finally have "H #> (g1 \<otimes> g2) = H #> (g2 \<otimes> g1)" .
+      then obtain h' where "h' \<in> H" "\<one> \<otimes> (g1 \<otimes> g2) = h' \<otimes> (g2 \<otimes> g1)"
+        using H.one_closed unfolding r_coset_def by blast
+      thus "h \<in> H"
+        using h m_assoc by auto
+    qed
   qed
 qed
 
-lemma (in group) exp_of_derived_in_carrier:
-  assumes "H \<subseteq> carrier G"
-  shows "(derived G ^^ n) H \<subseteq> carrier G" using assms
-proof (induction n)
-  case 0 thus ?case by simp
-next
-  case (Suc n)
-  have "(derived G ^^ Suc n) H = (derived G) ((derived G ^^ n) H)" by simp
-  also have " ... \<subseteq> (derived G) (carrier G)"
-    using mono_derived[of "carrier G" "(derived G ^^ n) H" 1] Suc by simp
-  also have " ... \<subseteq> carrier G" unfolding derived_def
-    by (simp add: derived_set_incl generate_min_subgroup1 subgroup_self)
-  finally show ?case .
+proposition (in group) derived_of_subgroup_minimal:
+  assumes "K \<lhd> G \<lparr> carrier := H \<rparr>" "subgroup H G" and "comm_group ((G \<lparr> carrier := H \<rparr>) Mod K)"
+  shows "derived G H \<subseteq> K"
+  using group.derived_minimal[OF subgroup_imp_group[OF assms(2)] assms(1,3)]
+        derived_consistent[OF _ assms(2)]
+  by simp
+
+lemma (in group_hom) derived_img:
+  assumes "K \<subseteq> carrier G" shows "derived H (h ` K) = h ` (derived G K)"
+proof -
+  have "derived_set H (h ` K) = h ` (derived_set G K)"
+  proof
+    show "derived_set H (h ` K) \<subseteq> h ` derived_set G K"
+    proof
+      fix a assume "a \<in> derived_set H (h ` K)"
+      then obtain k1 k2
+        where "k1 \<in> K" "k2 \<in> K" "a = (h k1) \<otimes>\<^bsub>H\<^esub> (h k2) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k1) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k2)"
+        by auto
+      hence "a = h (k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2)"
+        using assms by (simp add: subset_iff)
+      from this \<open>k1 \<in> K\<close> and \<open>k2 \<in> K\<close> show "a \<in> h ` derived_set G K" by auto
+    qed
+  next
+    show "h ` (derived_set G K) \<subseteq> derived_set H (h ` K)"
+    proof
+      fix a assume "a \<in> h ` (derived_set G K)"
+      then obtain k1 k2 where "k1 \<in> K" "k2 \<in> K" "a = h (k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2)"
+        by auto
+      hence "a = (h k1) \<otimes>\<^bsub>H\<^esub> (h k2) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k1) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k2)"
+        using assms by (simp add: subset_iff)
+      from this \<open>k1 \<in> K\<close> and \<open>k2 \<in> K\<close> show "a \<in> derived_set H (h ` K)" by auto
+    qed
+  qed
+  thus ?thesis
+    unfolding derived_def using generate_img[OF G.derived_set_in_carrier[OF assms]] by simp
 qed
 
-lemma (in group) exp_of_derived_is_subgroup:
-  assumes "subgroup H G"
-  shows "subgroup ((derived G ^^ n) H) G" using assms
-proof (induction n)
-  case 0 thus ?case by simp
-next
-  case (Suc n)
-  have "(derived G ^^ n) H \<subseteq> carrier G"
-    by (simp add: Suc.IH assms subgroup.subset)
-  hence "subgroup ((derived G) ((derived G ^^ n) H)) G"
-    unfolding derived_def using derived_set_in_carrier generate_is_subgroup by auto
-  thus ?case by simp
-qed
+lemma (in group_hom) exp_of_derived_img:
+  assumes "K \<subseteq> carrier G" shows "(derived H ^^ n) (h ` K) = h ` ((derived G ^^ n) K)"
+  using derived_img[OF G.exp_of_derived_in_carrier[OF assms]] by (induct n) (auto)
 
-hide_const (open) norm
-
-end
+end
\ No newline at end of file
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Group.thy
--- a/src/HOL/Algebra/Group.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Group.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -781,6 +781,19 @@
     {h. h \<in> carrier G \<rightarrow> carrier H \<and>
       (\<forall>x \<in> carrier G. \<forall>y \<in> carrier G. h (x \<otimes>\<^bsub>G\<^esub> y) = h x \<otimes>\<^bsub>H\<^esub> h y)}"
 
+
+(* NEW ========================================================================== *)
+lemma hom_trans:
+  "\<lbrakk> f \<in> hom G H; g \<in> hom H I \<rbrakk> \<Longrightarrow> g \<circ> f \<in> hom G I"
+  unfolding hom_def by (auto simp add: Pi_iff)
+(* ============================================================================== *)
+
+(* NEW ============================================================================ *)
+lemma (in group) hom_restrict:
+  assumes "h \<in> hom G H" and "\<And>g. g \<in> carrier G \<Longrightarrow> h g = t g" shows "t \<in> hom G H"
+  using assms unfolding hom_def by (auto simp add: Pi_iff)
+(* ============================================================================== *)
+
 lemma (in group) hom_compose:
   "[|h \<in> hom G H; i \<in> hom H I|] ==> compose (carrier G) i h \<in> hom G I"
 by (fastforce simp add: hom_def compose_def)
@@ -838,6 +851,12 @@
 corollary (in group) iso_trans: "\<lbrakk>G \<cong> H ; H \<cong> I\<rbrakk> \<Longrightarrow> G \<cong> I"
   using iso_set_trans unfolding is_iso_def by blast
 
+(* NEW ====================================================================== *)
+lemma iso_same_card: "G \<cong> H \<Longrightarrow> card (carrier G) = card (carrier H)"
+  using bij_betw_same_card  unfolding is_iso_def iso_def by auto
+(* ========================================================================== *)
+
+
 (* Next four lemmas contributed by Paulo. *)
 
 lemma (in monoid) hom_imp_img_monoid:
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Ideal.thy
--- a/src/HOL/Algebra/Ideal.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Ideal.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -39,7 +39,7 @@
 proof -
   interpret ring R by fact
   show ?thesis  
-    by (auto simp: ideal.intro ideal_axioms.intro additive_subgroupI a_subgroup is_ring I_l_closed I_r_closed)
+    by (auto simp: ideal.intro ideal_axioms.intro additive_subgroupI a_subgroup ring_axioms I_l_closed I_r_closed)
 qed
 
 
@@ -68,6 +68,46 @@
       (rule is_ideal, rule generate)
 qed
 
+(* NEW ====== *)
+lemma (in ideal) rcos_const_imp_mem:
+  assumes "i \<in> carrier R" and "I +> i = I" shows "i \<in> I"
+  using additive_subgroup.zero_closed[OF ideal.axioms(1)[OF ideal_axioms]] assms
+  by (force simp add: a_r_coset_def')
+(* ========== *)
+
+(* NEW ====== *)
+lemma (in ring) a_rcos_zero:
+  assumes "ideal I R" "i \<in> I" shows "I +> i = I"
+  using abelian_subgroupI3[OF ideal.axioms(1) is_abelian_group]
+  by (simp add: abelian_subgroup.a_rcos_const assms)
+(* ========== *)
+
+(* NEW ====== *)
+lemma (in ring) ideal_is_normal:
+  assumes "ideal I R" shows "I \<lhd> (add_monoid R)"
+  using abelian_subgroup.a_normal[OF abelian_subgroupI3[OF ideal.axioms(1)]]
+        abelian_group_axioms assms
+  by auto 
+(* ========== *)
+
+(* NEW ====== *)
+lemma (in ideal) a_rcos_sum:
+  assumes "a \<in> carrier R" and "b \<in> carrier R" shows "(I +> a) <+> (I +> b) = I +> (a \<oplus> b)"
+  using normal.rcos_sum[OF ideal_is_normal[OF ideal_axioms]] assms
+  unfolding set_add_def a_r_coset_def by simp
+(* ========== *)
+
+(* NEW ====== *)
+lemma (in ring) set_add_comm:
+  assumes "I \<subseteq> carrier R" "J \<subseteq> carrier R" shows "I <+> J = J <+> I"
+proof -
+  { fix I J assume "I \<subseteq> carrier R" "J \<subseteq> carrier R" hence "I <+> J \<subseteq> J <+> I"
+      using a_comm unfolding set_add_def' by (auto, blast) }
+  thus ?thesis
+    using assms by auto
+qed
+(* ========== *)
+
 
 subsubsection \<open>Maximal Ideals\<close>
 
@@ -128,9 +168,10 @@
 proof -
   interpret additive_subgroup I R by fact
   interpret cring R by fact
-  show ?thesis
-    apply intro_locales
-    apply (simp add: I_l_closed I_r_closed ideal_axioms_def)
+  show ?thesis apply intro_locales
+    apply (intro ideal_axioms.intro)
+    apply (erule (1) I_l_closed)
+    apply (erule (1) I_r_closed)
     by (simp add: I_notcarr I_prime primeideal_axioms.intro)
 qed
 
@@ -138,10 +179,10 @@
 subsection \<open>Special Ideals\<close>
 
 lemma (in ring) zeroideal: "ideal {\<zero>} R"
-  by (intro idealI subgroup.intro) (simp_all add: is_ring)
+  by (intro idealI subgroup.intro) (simp_all add: ring_axioms)
 
 lemma (in ring) oneideal: "ideal (carrier R) R"
-  by (rule idealI) (auto intro: is_ring add.subgroupI)
+  by (rule idealI) (auto intro: ring_axioms add.subgroupI)
 
 lemma (in "domain") zeroprimeideal: "primeideal {\<zero>} R"
 proof -
@@ -186,7 +227,7 @@
     by (force simp: a_subset)
   show ?thesis
     apply (intro idealI subgroup.intro)
-    apply (simp_all add: IJ is_ring I_l_closed assms ideal.I_l_closed ideal.I_r_closed flip: a_inv_def)
+    apply (simp_all add: IJ ring_axioms I_l_closed assms ideal.I_l_closed ideal.I_r_closed flip: a_inv_def)
     done
 qed
 
@@ -239,7 +280,7 @@
   show "additive_subgroup (I <+> J) R"
     by (intro ideal.axioms[OF idealI] ideal.axioms[OF idealJ] add_additive_subgroups)
   show "ring R"
-    by (rule is_ring)
+    by (rule ring_axioms)
   show "ideal_axioms (I <+> J) R"
   proof -
     { fix x i j
@@ -347,17 +388,14 @@
 text \<open>Generation of Principal Ideals in Commutative Rings\<close>
 
 definition cgenideal :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set"  ("PIdl\<index> _" [80] 79)
-  where "cgenideal R a \<equiv> {x \<otimes>\<^bsub>R\<^esub> a | x. x \<in> carrier R}"
-
-lemma cginideal_def': "cgenideal R a = (\<lambda>x. x \<otimes>\<^bsub>R\<^esub> a) ` carrier R"
-  by (auto simp add: cgenideal_def)
+  where "cgenideal R a = {x \<otimes>\<^bsub>R\<^esub> a | x. x \<in> carrier R}"
 
 text \<open>genhideal (?) really generates an ideal\<close>
 lemma (in cring) cgenideal_ideal:
   assumes acarr: "a \<in> carrier R"
   shows "ideal (PIdl a) R"
   unfolding cgenideal_def
-proof (intro subgroup.intro idealI[OF is_ring], simp_all)
+proof (intro subgroup.intro idealI[OF ring_axioms], simp_all)
   show "{x \<otimes> a |x. x \<in> carrier R} \<subseteq> carrier R"
     by (blast intro: acarr)
   show "\<And>x y. \<lbrakk>\<exists>u. x = u \<otimes> a \<and> u \<in> carrier R; \<exists>x. y = x \<otimes> a \<and> x \<in> carrier R\<rbrakk>
@@ -431,7 +469,7 @@
   shows "Idl (I \<union> J) = I <+> J"
 proof
   show "Idl (I \<union> J) \<subseteq> I <+> J"
-  proof (rule ring.genideal_minimal [OF is_ring])
+  proof (rule ring.genideal_minimal [OF ring_axioms])
     show "ideal (I <+> J) R"
       by (rule add_ideals[OF idealI idealJ])
     have "\<And>x. x \<in> I \<Longrightarrow> \<exists>xa\<in>I. \<exists>xb\<in>J. x = xa \<oplus> xb"
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/QuotRing.thy
--- a/src/HOL/Algebra/QuotRing.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/QuotRing.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -214,6 +214,39 @@
   shows "inj_on h (carrier R)"
   using group_hom.trivial_ker_imp_inj[OF a_group_hom] assms a_kernel_def[of R S h] by simp 
 
+(* NEW ========================================================================== *)
+lemma (in ring_hom_ring) inj_iff_trivial_ker:
+  shows "inj_on h (carrier R) \<longleftrightarrow> a_kernel R S h = { \<zero> }"
+  using group_hom.inj_iff_trivial_ker[OF a_group_hom] a_kernel_def[of R S h] by simp
+
+(* NEW ========================================================================== *)
+corollary ring_hom_in_hom:
+  assumes "h \<in> ring_hom R S" shows "h \<in> hom R S" and "h \<in> hom (add_monoid R) (add_monoid S)"
+  using assms unfolding ring_hom_def hom_def by auto 
+
+(* NEW ========================================================================== *)
+corollary set_add_hom:
+  assumes "h \<in> ring_hom R S" "I \<subseteq> carrier R" and "J \<subseteq> carrier R"
+  shows "h ` (I <+>\<^bsub>R\<^esub> J) = h ` I <+>\<^bsub>S\<^esub> h ` J"
+  using set_mult_hom[OF ring_hom_in_hom(2)[OF assms(1)]] assms(2-3)
+  unfolding a_kernel_def[of R S h] set_add_def by simp
+
+(* NEW ========================================================================== *)
+corollary a_coset_hom:
+  assumes "h \<in> ring_hom R S" "I \<subseteq> carrier R" "a \<in> carrier R"
+  shows "h ` (a <+\<^bsub>R\<^esub> I) = h a <+\<^bsub>S\<^esub> (h ` I)" and "h ` (I +>\<^bsub>R\<^esub> a) = (h ` I) +>\<^bsub>S\<^esub> h a"
+  using assms coset_hom[OF ring_hom_in_hom(2)[OF assms(1)], of I a]
+  unfolding a_l_coset_def l_coset_eq_set_mult
+            a_r_coset_def r_coset_eq_set_mult
+  by simp_all
+
+(* NEW ========================================================================== *)
+corollary (in ring_hom_ring) set_add_ker_hom:
+  assumes "I \<subseteq> carrier R"
+  shows "h ` (I <+> (a_kernel R S h)) = h ` I" and "h ` ((a_kernel R S h) <+> I) = h ` I"
+  using group_hom.set_mult_ker_hom[OF a_group_hom] assms
+  unfolding a_kernel_def[of R S h] set_add_def by simp+
+
 lemma (in ring_hom_ring) non_trivial_field_hom_imp_inj:
   assumes "field R"
   shows "h ` (carrier R) \<noteq> { \<zero>\<^bsub>S\<^esub> } \<Longrightarrow> inj_on h (carrier R)"
@@ -226,6 +259,23 @@
   thus "inj_on h (carrier R)"
     using trivial_ker_imp_inj by blast
 qed
+lemma "field R \<Longrightarrow> cring R"
+  using fieldE(1) by blast
+
+lemma non_trivial_field_hom_is_inj:
+  assumes "h \<in> ring_hom R S" and "field R" and "field S" shows "inj_on h (carrier R)"
+proof -
+  interpret ring_hom_cring R S h
+    using assms(1) ring_hom_cring.intro[OF assms(2-3)[THEN fieldE(1)]]
+    unfolding symmetric[OF ring_hom_cring_axioms_def] by simp
+
+  have "h \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>" and "\<one>\<^bsub>S\<^esub> \<noteq> \<zero>\<^bsub>S\<^esub>"
+    using domain.one_not_zero[OF field.axioms(1)[OF assms(3)]] by auto 
+  hence "h ` (carrier R) \<noteq> { \<zero>\<^bsub>S\<^esub> }"
+    using ring.kernel_zero ring.trivial_hom_iff by fastforce
+  thus ?thesis
+    using ring.non_trivial_field_hom_imp_inj[OF assms(2)] by simp
+qed    
 
 lemma (in ring_hom_ring) img_is_add_subgroup:
   assumes "subgroup H (add_monoid R)"
@@ -538,24 +588,21 @@
     and "\<And>r1 r2. \<lbrakk> r1 \<in> carrier R; r2 \<in> carrier R \<rbrakk> \<Longrightarrow> P (r1 \<oplus> r2)"
   using assms unfolding morphic_prop_def by auto
 
-lemma ring_iso_restrict:
-  assumes "f \<in> ring_iso R S"
-    and "\<And>r. r \<in> carrier R \<Longrightarrow> f r = g r"
-    and "ring R"
-  shows "g \<in> ring_iso R S"
-proof (rule ring_iso_memI)
-  show "bij_betw g (carrier R) (carrier S)"
-    using assms(1-2) bij_betw_cong ring_iso_memE(5) by blast
-  show "g \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>"
-    using assms ring.ring_simprules(6) ring_iso_memE(4) by force
-next
-  fix x y assume x: "x \<in> carrier R" and y: "y \<in> carrier R"
-  show "g x \<in> carrier S"
-    using assms(1-2) ring_iso_memE(1) x by fastforce
-  show "g (x \<otimes>\<^bsub>R\<^esub> y) = g x \<otimes>\<^bsub>S\<^esub> g y"
-    by (metis assms ring.ring_simprules(5) ring_iso_memE(2) x y)
-  show "g (x \<oplus>\<^bsub>R\<^esub> y) = g x \<oplus>\<^bsub>S\<^esub> g y"
-    by (metis assms ring.ring_simprules(1) ring_iso_memE(3) x y)
+(* NEW ============================================================================ *)
+lemma (in ring) ring_hom_restrict:
+  assumes "f \<in> ring_hom R S" and "\<And>r. r \<in> carrier R \<Longrightarrow> f r = g r" shows "g \<in> ring_hom R S"
+  using assms(2) ring_hom_memE[OF assms(1)] by (auto intro: ring_hom_memI)
+
+(* PROOF ========================================================================== *)
+lemma (in ring) ring_iso_restrict:
+  assumes "f \<in> ring_iso R S" and "\<And>r. r \<in> carrier R \<Longrightarrow> f r = g r" shows "g \<in> ring_iso R S"
+proof -
+  have hom: "g \<in> ring_hom R S"
+    using ring_hom_restrict assms unfolding ring_iso_def by auto 
+  have "bij_betw g (carrier R) (carrier S)"
+    using bij_betw_cong[of "carrier R" f g] ring_iso_memE(5)[OF assms(1)] assms(2) by simp
+  thus ?thesis
+    using ring_hom_memE[OF hom] by (auto intro!: ring_iso_memI)
 qed
 
 lemma ring_iso_morphic_prop:
@@ -580,7 +627,7 @@
 
 lemma (in ring) ring_hom_imp_img_ring:
   assumes "h \<in> ring_hom R S"
-  shows "ring (S \<lparr> carrier := h ` (carrier R), one := h \<one>, zero := h \<zero> \<rparr>)" (is "ring ?h_img")
+  shows "ring (S \<lparr> carrier := h ` (carrier R), zero := h \<zero> \<rparr>)" (is "ring ?h_img")
 proof -
   have "h \<in> hom (add_monoid R) (add_monoid S)"
     using assms unfolding hom_def ring_hom_def by auto
@@ -594,8 +641,7 @@
   hence "monoid (S \<lparr>  carrier := h ` (carrier R), one := h \<one> \<rparr>)"
     using hom_imp_img_monoid[of h S] by simp
   hence monoid: "monoid ?h_img"
-    unfolding monoid_def by (simp add: monoid.defs)
-
+    using ring_hom_memE(4)[OF assms] unfolding monoid_def by (simp add: monoid.defs)
   show ?thesis
   proof (rule ringI, simp_all add: comm_group_abelian_groupI[OF comm_group] monoid)
     fix x y z assume "x \<in> h ` carrier R" "y \<in> h ` carrier R" "z \<in> h ` carrier R"
@@ -623,9 +669,9 @@
 
 lemma (in ring) ring_iso_imp_img_ring:
   assumes "h \<in> ring_iso R S"
-  shows "ring (S \<lparr> one := h \<one>, zero := h \<zero> \<rparr>)"
+  shows "ring (S \<lparr> zero := h \<zero> \<rparr>)"
 proof -
-  have "ring (S \<lparr> carrier := h ` (carrier R), one := h \<one>, zero := h \<zero> \<rparr>)"
+  have "ring (S \<lparr> carrier := h ` (carrier R), zero := h \<zero> \<rparr>)"
     using ring_hom_imp_img_ring[of h S] assms unfolding ring_iso_def by auto
   moreover have "h ` (carrier R) = carrier S"
     using assms unfolding ring_iso_def bij_betw_def by auto
@@ -634,7 +680,7 @@
 
 lemma (in cring) ring_iso_imp_img_cring:
   assumes "h \<in> ring_iso R S"
-  shows "cring (S \<lparr> one := h \<one>, zero := h \<zero> \<rparr>)" (is "cring ?h_img")
+  shows "cring (S \<lparr> zero := h \<zero> \<rparr>)" (is "cring ?h_img")
 proof -
   note m_comm
   interpret h_img?: ring ?h_img
@@ -659,16 +705,20 @@
 
 lemma (in domain) ring_iso_imp_img_domain:
   assumes "h \<in> ring_iso R S"
-  shows "domain (S \<lparr> one := h \<one>, zero := h \<zero> \<rparr>)" (is "domain ?h_img")
+  shows "domain (S \<lparr> zero := h \<zero> \<rparr>)" (is "domain ?h_img")
 proof -
   note aux = m_closed integral one_not_zero one_closed zero_closed
   interpret h_img?: cring ?h_img
     using ring_iso_imp_img_cring[OF assms] .
   show ?thesis 
   proof (unfold_locales)
-    show "\<one>\<^bsub>?h_img\<^esub> \<noteq> \<zero>\<^bsub>?h_img\<^esub>"
+    have "\<one>\<^bsub>?h_img\<^esub> = \<zero>\<^bsub>?h_img\<^esub> \<Longrightarrow> h \<one> = h \<zero>"
+      using ring_iso_memE(4)[OF assms] by simp
+    moreover have "h \<one> \<noteq> h \<zero>"
       using ring_iso_memE(5)[OF assms] aux(3-4)
       unfolding bij_betw_def inj_on_def by force
+    ultimately show "\<one>\<^bsub>?h_img\<^esub> \<noteq> \<zero>\<^bsub>?h_img\<^esub>"
+      by auto
   next
     fix a b
     assume A: "a \<otimes>\<^bsub>?h_img\<^esub> b = \<zero>\<^bsub>?h_img\<^esub>" "a \<in> carrier ?h_img" "b \<in> carrier ?h_img"
@@ -693,21 +743,21 @@
 
 lemma (in field) ring_iso_imp_img_field:
   assumes "h \<in> ring_iso R S"
-  shows "field (S \<lparr> one := h \<one>, zero := h \<zero> \<rparr>)" (is "field ?h_img")
+  shows "field (S \<lparr> zero := h \<zero> \<rparr>)" (is "field ?h_img")
 proof -
   interpret h_img?: domain ?h_img
     using ring_iso_imp_img_domain[OF assms] .
   show ?thesis
   proof (unfold_locales, auto simp add: Units_def)
     interpret field R using field_axioms .
-    fix a assume a: "a \<in> carrier S" "a \<otimes>\<^bsub>S\<^esub> h \<zero> = h \<one>"
+    fix a assume a: "a \<in> carrier S" "a \<otimes>\<^bsub>S\<^esub> h \<zero> = \<one>\<^bsub>S\<^esub>"
     then obtain r where r: "r \<in> carrier R" "a = h r"
       using assms image_iff[where ?f = h and ?A = "carrier R"]
       unfolding ring_iso_def bij_betw_def by auto
     have "a \<otimes>\<^bsub>S\<^esub> h \<zero> = h (r \<otimes> \<zero>)" unfolding r(2)
       using ring_iso_memE(2)[OF assms r(1)] by simp
     hence "h \<one> = h \<zero>"
-      using r(1) a(2) by simp
+      using ring_iso_memE(4)[OF assms] r(1) a(2) by simp
     thus False
       using ring_iso_memE(5)[OF assms]
       unfolding bij_betw_def inj_on_def by force
@@ -723,19 +773,14 @@
     have "h (inv r) \<otimes>\<^bsub>S\<^esub> h r = h \<one>" and "h r \<otimes>\<^bsub>S\<^esub> h (inv r) = h \<one>"
       using ring_iso_memE(2)[OF assms inv_r(1) r(1)] inv_r(3-4)
             ring_iso_memE(2)[OF assms r(1) inv_r(1)] by auto
-    thus "\<exists>s' \<in> carrier S. s' \<otimes>\<^bsub>S\<^esub> s = h \<one> \<and> s \<otimes>\<^bsub>S\<^esub> s' = h \<one>"
-      using ring_iso_memE(1)[OF assms inv_r(1)] r(2) by auto
+    thus "\<exists>s' \<in> carrier S. s' \<otimes>\<^bsub>S\<^esub> s = \<one>\<^bsub>S\<^esub> \<and> s \<otimes>\<^bsub>S\<^esub> s' = \<one>\<^bsub>S\<^esub>"
+      using ring_iso_memE(1,4)[OF assms] inv_r(1) r(2) by auto
   qed
 qed
 
 lemma ring_iso_same_card: "R \<simeq> S \<Longrightarrow> card (carrier R) = card (carrier S)"
-proof -
-  assume "R \<simeq> S"
-  then obtain h where "bij_betw h (carrier R) (carrier S)"
-    unfolding is_ring_iso_def ring_iso_def by auto
-  thus "card (carrier R) = card (carrier S)"
-    using bij_betw_same_card[of h "carrier R" "carrier S"] by simp
-qed
+  using bij_betw_same_card unfolding is_ring_iso_def ring_iso_def by auto 
+(* ========================================================================== *)
 
 lemma ring_iso_set_refl: "id \<in> ring_iso R R"
   by (rule ring_iso_memI) (auto)
@@ -934,8 +979,7 @@
   have FactRing_is_ring: "ring (R Quot (a_kernel R S h))"
     by (simp add: ideal.quotient_is_ring kernel_is_ideal)
   have "ring ((S \<lparr> carrier := ?the_elem ` (carrier (R Quot (a_kernel R S h))) \<rparr>)
-                 \<lparr>     one := ?the_elem \<one>\<^bsub>(R Quot (a_kernel R S h))\<^esub>,
-                      zero := ?the_elem \<zero>\<^bsub>(R Quot (a_kernel R S h))\<^esub> \<rparr>)"
+                 \<lparr>    zero := ?the_elem \<zero>\<^bsub>(R Quot (a_kernel R S h))\<^esub> \<rparr>)"
     using ring.ring_iso_imp_img_ring[OF FactRing_is_ring, of ?the_elem
           "S \<lparr> carrier := ?the_elem ` (carrier (R Quot (a_kernel R S h))) \<rparr>"]
           FactRing_iso_set_aux the_elem_surj by auto
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Solvable_Groups.thy
--- a/src/HOL/Algebra/Solvable_Groups.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Solvable_Groups.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -3,162 +3,82 @@
 *)
 
 theory Solvable_Groups
-  imports Group Coset Generated_Groups
+  imports Generated_Groups
+    
 begin
 
-inductive solvable_seq :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> bool" for G where
-unity:       "solvable_seq G { \<one>\<^bsub>G\<^esub> }" |
-extension: "\<lbrakk> solvable_seq G K; K \<subset> H; subgroup H G; K \<lhd> (G \<lparr> carrier := H \<rparr>);
-              comm_group ((G \<lparr> carrier := H \<rparr>) Mod K) \<rbrakk> \<Longrightarrow> solvable_seq G H"
+section \<open>Solvable Groups\<close>
+
+subsection \<open>Definitions\<close>
 
-definition
-  solvable :: "('a, 'b) monoid_scheme \<Rightarrow> bool"
+inductive solvable_seq :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> bool"
+  for G where
+    unity: "solvable_seq G { \<one>\<^bsub>G\<^esub> }"
+  | extension: "\<lbrakk> solvable_seq G K; K \<lhd> (G \<lparr> carrier := H \<rparr>); subgroup H G;
+                  comm_group ((G \<lparr> carrier := H \<rparr>) Mod K) \<rbrakk> \<Longrightarrow> solvable_seq G H"
+
+definition solvable :: "('a, 'b) monoid_scheme \<Rightarrow> bool"
   where "solvable G \<longleftrightarrow> solvable_seq G (carrier G)"
 
 
 subsection \<open>Solvable Groups and Derived Subgroups\<close>
 
 text \<open>We show that a group G is solvable iff the subgroup (derived G ^^ n) (carrier G)
-      is trivial for a sufficiently large n\<close>
+      is trivial for a sufficiently large n. \<close>
 
 lemma (in group) solvable_imp_subgroup:
-  assumes "solvable_seq G H"
-  shows "subgroup H G" using assms
-proof (induction)
-  case unity thus ?case
-    using generate_empty generate_is_subgroup by force 
-next
-  case extension thus ?case by simp
-qed
+  assumes "solvable_seq G H" shows "subgroup H G"
+  using assms normal.axioms(1)[OF one_is_normal] by (induction) (auto)
 
 lemma (in group) augment_solvable_seq:
-  assumes "subgroup H G"
-    and "solvable_seq G (derived G H)"
-  shows "solvable_seq G H"
-proof (cases)
-  assume "derived G H = H" thus ?thesis
-    unfolding solvable_def using assms by simp
-next
-  assume "derived G H \<noteq> H"
-  thus ?thesis unfolding solvable_def
-    using solvable_seq.extension[OF assms(2), of H] assms(1)
-          derived_quot_of_subgroup_is_comm_group[of H, OF assms(1)]
-          derived_incl[OF assms(1)] derived_subgroup_is_normal[OF assms(1)] by simp
-qed
+  assumes "subgroup H G" and "solvable_seq G (derived G H)" shows "solvable_seq G H"
+  using extension[OF _ derived_subgroup_is_normal _ derived_quot_of_subgroup_is_comm_group] assms by simp
 
 theorem (in group) trivial_derived_seq_imp_solvable:
-  assumes "subgroup H G" and "((derived G) ^^ n) H = { \<one> }"
-  shows "solvable_seq G H" using assms
-proof (induction n arbitrary: H)
-  case 0 hence "H = { \<one> }" by simp thus ?case by (simp add: unity)
-next
-  case (Suc n)
-  hence "(derived G ^^ n) (derived G H) = { \<one> }"
-    by (simp add: funpow_swap1)
-  moreover have "subgroup (derived G H) G" unfolding derived_def
-    using Suc.prems(1) derived_set_incl generate_is_subgroup order.trans subgroup.subset
-    by (metis (no_types, lifting))
-  ultimately have "solvable_seq G (derived G H)" by (simp add: Suc.IH)
-  thus ?case by (simp add: Suc.prems(1) augment_solvable_seq)
+  assumes "subgroup H G" and "((derived G) ^^ n) H = { \<one> }" shows "solvable_seq G H"
+  using assms
+proof (induct n arbitrary: H, simp add: unity[of G])
+  case (Suc n) thus ?case
+    using augment_solvable_seq derived_is_subgroup[OF subgroup.subset] by (simp add: funpow_swap1)
 qed
 
 theorem (in group) solvable_imp_trivial_derived_seq:
-  assumes "solvable_seq G H" and "subgroup H G"
-  shows "\<exists>n. (derived G ^^ n) H = { \<one> }"
-proof -
-  { fix K H assume A: "K \<subseteq> H" "K \<lhd> (G \<lparr> carrier := H \<rparr>)" "subgroup K G" "subgroup H G"
-                      "comm_group ((G \<lparr> carrier := H \<rparr>) Mod K)"
-    have "derived G H \<subseteq> K"
-    proof -
-      have Hcarr: "\<And>a. a \<in> H \<Longrightarrow> a \<in> carrier G"
-        by (meson A(4) subgroup.mem_carrier)
-      have "derived_set G H \<subseteq> K"
-      proof
-        fix h assume "h \<in> derived_set G H"
-        then obtain h1 h2 where h12: "h1 \<in> H" "h2 \<in> H" "h = h1 \<otimes> h2 \<otimes> inv h1 \<otimes> inv h2" by blast
-
-        hence K_h12: "(K #> (h1 \<otimes> h2)) \<in> carrier ((G \<lparr> carrier := H \<rparr>) Mod K)"
-          unfolding FactGroup_def RCOSETS_def r_coset_def apply simp by (metis A(4) subgroup_def)
-        have K_h1: "K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> h1 \<in> carrier ((G \<lparr> carrier := H \<rparr>) Mod K)"
-          unfolding FactGroup_def RCOSETS_def r_coset_def apply simp using h12(1) by blast
-        have K_h2: "K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> h2 \<in> carrier ((G \<lparr> carrier := H \<rparr>) Mod K)"
-          unfolding FactGroup_def RCOSETS_def r_coset_def apply simp using h12(2) by blast
-
-        hence "K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> (h1 \<otimes> h2) =
-              (K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> h1) <#>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> (K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> h2)"
-          using normal.rcos_sum[OF A(2),of h1 h2] h12(1-2) by simp
-        also have " ... =
-              (K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> h2) <#>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> (K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> h1)"
-          using comm_groupE(4)[OF A(5) K_h1 K_h2] by simp
-        finally have "K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> (h1 \<otimes> h2) = K #>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> (h2 \<otimes> h1)"
-          using normal.rcos_sum[OF A(2),of h2 h1] h12(1-2) by simp
-
-        moreover have h12H: "h1 \<otimes> h2 \<in> H" and "h2 \<otimes> h1 \<in> H"
-          using h12 subgroupE(4)[OF A(4)] by auto
-        ultimately have "K #> (h1 \<otimes> h2) = K #> (h2 \<otimes> h1)" by auto
-
-        then obtain k where k: "k \<in> K" "\<one> \<otimes> (h1 \<otimes> h2) = k \<otimes> (h2 \<otimes> h1)"
-          using subgroup.one_closed[OF A(3)] unfolding r_coset_def by blast
-        hence "(h1 \<otimes> h2) \<otimes> (inv h1 \<otimes> inv h2) = k"
-        proof -
-          have "k \<in> carrier G"
-            by (meson A(3) k(1) subgroup.mem_carrier)
-          with Hcarr h12 show ?thesis
-            by (metis h12H inv_mult_group inv_solve_right k(2) r_cancel_one' subgroup_def subgroup_self)
-        qed
-        hence "h = k" using h12
-          by (meson A(4) \<open>h1 \<otimes> h2 \<in> H\<close> inv_closed m_assoc subgroup.mem_carrier)
-        thus "h \<in> K" using k(1) by simp
-      qed
-      thus ?thesis unfolding derived_def by (meson A(3) generateE(3) order.trans subgroupE(1))
-    qed } note aux_lemma = this
-
-  show "\<exists>n. (derived G ^^ n) H = { \<one> }" using assms
-  proof (induct H rule: solvable_seq.induct)
-    case unity have "(derived G ^^ 0) { \<one> } = { \<one> }" by simp thus ?case by blast 
-  next
-    case (extension K H)
-    then obtain n where n: "(derived G ^^ n) K = { \<one> }"
-      using solvable_imp_subgroup extension by blast
-    have "derived G H \<subseteq> K" using solvable_imp_subgroup extension aux_lemma by blast
-    hence "(derived G ^^ n) (derived G H) \<subseteq> (derived G ^^ n) K"
-      using mono_derived solvable_imp_subgroup extension.hyps(4)
-      by (simp add: extension.hyps(1) subgroup.subset) 
-    hence "(derived G ^^ (Suc n)) H \<subseteq> { \<one> }"
-      by (metis funpow_simps_right(2) n o_apply)
-    moreover have "\<one> \<in> derived G ((derived G ^^ n) H)"
-      unfolding derived_def using generate.one by auto
-    hence "{ \<one> } \<subseteq> (derived G ^^ (Suc n)) H" by simp
-    ultimately show ?case by blast
-  qed
+  assumes "solvable_seq G H" shows "\<exists>n. (derived G ^^ n) H = { \<one> }"
+  using assms
+proof (induction)
+  case unity
+  have "(derived G ^^ 0) { \<one> } = { \<one> }"
+    by simp
+  thus ?case by blast
+next
+  case (extension K H)
+  obtain n where "(derived G ^^ n) K = { \<one> }"
+    using solvable_imp_subgroup extension(1,5) by auto
+  hence "(derived G ^^ (Suc n)) H \<subseteq> { \<one> }"
+    using mono_exp_of_derived[OF derived_of_subgroup_minimal[OF extension(2-4)], of n] by (simp add: funpow_swap1)
+  moreover have "{ \<one> } \<subseteq> (derived G ^^ (Suc n)) H"
+    using subgroup.one_closed[OF exp_of_derived_is_subgroup[OF extension(3)], of "Suc n"] by auto
+  ultimately show ?case
+    by blast
 qed
 
 theorem (in group) solvable_iff_trivial_derived_seq:
   "solvable G \<longleftrightarrow> (\<exists>n. (derived G ^^ n) (carrier G) = { \<one> })"
-  unfolding solvable_def
-  using solvable_imp_trivial_derived_seq subgroup_self
-        trivial_derived_seq_imp_solvable by blast
+  using solvable_imp_trivial_derived_seq subgroup_self trivial_derived_seq_imp_solvable
+  by (auto simp add: solvable_def)
 
 corollary (in group) solvable_subgroup:
-  assumes "subgroup H G"
-  shows "solvable G \<Longrightarrow> solvable_seq G H"
+  assumes "subgroup H G" and "solvable G" shows "solvable_seq G H"
 proof -
-  { fix I J assume A: "subgroup I G" "subgroup J G" "I \<subseteq> J" "solvable_seq G J"
-    have "solvable_seq G I"
-    proof -
-      obtain n where "(derived G ^^ n) J = { \<one> }"
-        using solvable_imp_trivial_derived_seq[OF A(4) A(2)] by auto
-      hence "(derived G ^^ n) I \<subseteq> { \<one> }"
-        using mono_derived[OF subgroup.subset[OF A(2)] A(3)] by auto
-      hence "(derived G ^^ n) I = { \<one> }"
-        using subgroup.one_closed[OF exp_of_derived_is_subgroup[OF A(1), of n]] by auto
-      thus ?thesis
-        using trivial_derived_seq_imp_solvable[OF A(1), of n] by auto
-    qed } note aux_lemma = this
-  assume "solvable G"
-  thus ?thesis
-    using aux_lemma[OF assms subgroup_self subgroup.subset[OF assms]]
-    unfolding solvable_def by simp 
+  obtain n where n: "(derived G ^^ n) (carrier G) = { \<one> }"
+    using assms(2) solvable_imp_trivial_derived_seq by (auto simp add: solvable_def)
+  show ?thesis
+  proof (rule trivial_derived_seq_imp_solvable[OF assms(1), of n])
+    show "(derived G ^^ n) H = { \<one> }"
+      using subgroup.one_closed[OF exp_of_derived_is_subgroup[OF assms(1)], of n]
+            mono_exp_of_derived[OF subgroup.subset[OF assms(1)], of n] n
+      by auto
+  qed
 qed
 
 
@@ -168,275 +88,78 @@
       injective homomorphism from a group H to a group G, if H isn't solvable the group G
       isn't neither. \<close>
 
-lemma (in group_hom) generate_of_img:
-  assumes "K \<subseteq> carrier G"
-  shows "generate H (h ` K) = h ` (generate G K)"
-proof
-  have img_in_carrier: "h ` K \<subseteq> carrier H"
-    by (meson assms group_hom.hom_closed group_hom_axioms image_subsetI subsetCE)
-
-  show "generate H (h ` K) \<subseteq> h ` generate G K"
-  proof
-    fix x assume "x \<in> generate H (h ` K)"
-    then obtain r where r: "elts r \<subseteq> (h ` K)" "Generated_Groups.norm H r = x"
-      using H.generate_repr_iff img_in_carrier by auto
-    from \<open>elts r \<subseteq> (h ` K)\<close> have "Generated_Groups.norm H r \<in> h ` generate G K"
-    proof (induct r rule: repr.induct)
-      case One
-      have "\<one>\<^bsub>G\<^esub> \<in> generate G K" using generate.one[of G] by simp
-      hence "h \<one>\<^bsub>G\<^esub> \<in> h ` generate G K" by blast
-      thus ?case by simp
-    next
-      case (Inv x) hence "x \<in> h ` K" by simp
-      then obtain k where k: "k \<in> K" "x = h k" by blast
-      hence "inv\<^bsub>H\<^esub> x = h (inv k)" using assms by auto
-      thus ?case using k by (simp add: generate.inv)
-    next
-      case (Leaf x) hence "x \<in> h ` K" by simp
-      then obtain k where "k \<in> K" "x = h k" by blast
-      thus ?case by (simp add: generate.incl)
-    next
-      case (Mult x1 x2) hence A: "elts x1 \<union> elts x2 \<subseteq> h ` K" by simp
-      have "Generated_Groups.norm H x1 \<in> h ` (generate G K)" using A Mult by simp
-      moreover have "Generated_Groups.norm H x2 \<in> h ` (generate G K)" using A Mult by simp
-      ultimately obtain k1 k2 where k1: "k1 \<in> generate G K" "Generated_Groups.norm H x1 = h k1"
-                                and k2: "k2 \<in> generate G K" "Generated_Groups.norm H x2 = h k2" by blast
-      hence "Generated_Groups.norm H (Mult x1 x2) = h (k1 \<otimes> k2)"
-        using G.generate_in_carrier assms by auto
-      thus ?case using k1 k2 by (simp add: generate.eng) 
-    qed
-    thus "x \<in> h ` generate G K" using r by simp
-  qed
-
-next
-  show "h ` generate G K \<subseteq> generate H (h ` K)"
-  proof
-    fix x assume "x \<in> h ` generate G K"
-    then obtain r where r: "elts r \<subseteq> K" "x = h (Generated_Groups.norm G r)" using G.generate_repr_iff assms by auto
-    from \<open>elts r \<subseteq> K\<close> have "h (Generated_Groups.norm G r) \<in> generate H (h ` K)"
-    proof (induct r rule: repr.induct)
-      case One thus ?case by (simp add: generate.one) 
-    next
-      case (Inv x) hence A: "x \<in> K" by simp
-      hence "h (Generated_Groups.norm G (Inv x)) = inv\<^bsub>H\<^esub> (h x)" using assms by auto
-      moreover have "h x \<in> generate H (h ` K)" using A by (simp add: generate.incl)
-      ultimately show ?case by (simp add: A generate.inv)
-    next
-      case (Leaf x) thus ?case by (simp add: generate.incl)
-    next
-      case (Mult x1 x2) hence A: "elts x1 \<union> elts x2 \<subseteq> K" by simp
-      have "Generated_Groups.norm G x1 \<in> carrier G"
-        by (meson A G.generateE(1) G.generate_repr_iff Un_subset_iff assms subgroup.mem_carrier)
-      moreover have "Generated_Groups.norm G x2 \<in> carrier G"
-        by (meson A G.generateE(1) G.generate_repr_iff Un_subset_iff assms subgroup.mem_carrier)
-      ultimately have "h (Generated_Groups.norm G (Mult x1 x2)) = h (Generated_Groups.norm G x1) \<otimes>\<^bsub>H\<^esub> h (Generated_Groups.norm G x2)" by simp
-      thus ?case using Mult A by (simp add: generate.eng) 
-    qed
-    thus "x \<in> generate H (h ` K)" using r by simp
-  qed
-qed
-
-lemma (in group_hom) derived_of_img:
-  assumes "K \<subseteq> carrier G"
-  shows "(derived H ^^ n) (h ` K) = h ` ((derived G ^^ n) K)"
+theorem (in group_hom) solvable_img_imp_solvable:
+  assumes "subgroup K G" and "inj_on h K" and "solvable_seq H (h ` K)" shows "solvable_seq G K"
 proof -
-  { fix K assume A: "K \<subseteq> carrier G"
-    have "derived H (h ` K) = h ` (derived G K)"
-    proof -
-      have Kcarr: "\<And>a. a \<in> K \<Longrightarrow> a \<in> carrier G"
-        by (metis (no_types) A subsetCE)
-      have "derived_set H (h ` K) = h ` (derived_set G K)"
-      proof
-        show "derived_set H (h ` K) \<subseteq> h ` derived_set G K"
-        proof
-          fix x assume "x \<in> derived_set H (h ` K)"
-          then obtain k1 k2
-            where k12: "k1 \<in> K" "k2 \<in> K"
-              and xeq: "x = (h k1) \<otimes>\<^bsub>H\<^esub> (h k2) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k1) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub>(h k2)" by blast
-          hence "x = h (k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2)"
-          proof -
-            have "k1 \<in> carrier G" "k2 \<in> carrier G"
-              using A \<open>k1 \<in> K\<close> \<open>k2 \<in> K\<close> by blast+
-            then show ?thesis
-              using G.inv_closed G.m_closed xeq hom_inv hom_mult by presburger
-          qed
-          thus "x \<in> h ` (derived_set G K)" using k12 by blast
-        qed
-      next
-        show "h ` derived_set G K \<subseteq> derived_set H (h ` K)"
-        proof
-          fix x assume " x \<in> h ` derived_set G K"
-          then obtain k1 k2 where k12: "k1 \<in> K" "k2 \<in> K"
-                              and "x = h (k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2)" by blast
-          hence "x = (h k1) \<otimes>\<^bsub>H\<^esub> (h k2) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k1) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub>(h k2)"
-            by (metis (no_types) Kcarr G.inv_closed G.m_closed hom_inv hom_mult)
-          thus "x \<in> derived_set H (h ` K)" using k12 by blast
-        qed
-      qed
-      thus ?thesis unfolding derived_def using generate_of_img
-        by (simp add: G.derived_set_in_carrier A)
-    qed } note aux_lemma = this
-
-  from \<open>K \<subseteq> carrier G\<close> show ?thesis
-  proof (induction n)
-    case 0 thus ?case by simp
-  next
-    case (Suc n)
-    have "(derived H ^^ Suc n) (h ` K) = (derived H) ((derived H ^^ n) (h ` K))" by simp
-    also have " ... = (derived H) (h ` ((derived G ^^ n) K))" using Suc by simp
-    also have " ... = h ` ((derived G) ((derived G ^^ n) K))"
-      using aux_lemma[of "(derived G ^^ n) K"] G.exp_of_derived_in_carrier[OF Suc(2),of n] by linarith
-    also have " ... = h ` ((derived G ^^ (Suc n)) K)" by simp
-    finally show ?case . 
-  qed
-qed
-
-theorem (in group_hom) solvable_img_imp_solvable:
-  assumes "subgroup I G"
-    and "inj_on h I"
-    and "solvable_seq H (h ` I)"
-  shows "solvable_seq G I"
-proof -
-  { fix n I assume A: "subgroup I G" "inj_on h I"
-    hence "inj_on h ((derived G ^^ n) I)"
-    proof -
-      have "(derived G  ^^ n) I \<subseteq> I"
-      proof (induction n)
-        case 0 thus ?case by simp
-      next
-        case (Suc n)
-        hence "(derived G) ((derived G ^^ n) I) \<subseteq> (derived G) I"
-          using G.mono_derived[of I "(derived G ^^ n) I" 1,
-                               OF subgroup.subset[OF A(1)] Suc] by simp
-        thus ?case using A(1) G.derived_incl by auto
-      qed
-      thus ?thesis using A(2) inj_on_subset by blast
-    qed } note aux_lemma = this
-
-  obtain n where "(derived H ^^ n) (h ` I) = { \<one>\<^bsub>H\<^esub> }"
-    using H.solvable_imp_subgroup H.solvable_imp_trivial_derived_seq assms(3) by blast
-  hence "h ` ((derived G ^^ n) I) = { \<one>\<^bsub>H\<^esub> }"
-    by (metis derived_of_img assms(1) subgroup.subset)
-  moreover have "inj_on h ((derived G ^^ n) I)"
-    using aux_lemma[OF assms(1-2), of n] by simp
-  hence "\<And>x. \<lbrakk> x \<in> ((derived G ^^ n) I); h x = \<one>\<^bsub>H\<^esub> \<rbrakk> \<Longrightarrow> x = \<one>"
-    by (metis G.exp_of_derived_is_subgroup assms(1) hom_one inj_on_eq_iff subgroup_def)
-  ultimately have "(derived G ^^ n) I = { \<one> }" by blast
-  thus ?thesis
-    using G.trivial_derived_seq_imp_solvable[OF assms(1), of n] by simp
-qed
-
-corollary (in group_hom) not_solvable:
-  assumes "inj_on h (carrier G)"
-    and "\<not> solvable G"
-  shows "\<not> solvable H"
-proof -
-  { fix I J assume A: "subgroup I H" "subgroup J H" "I \<subseteq> J" "solvable_seq H J"
-    have "solvable_seq H I"
-    proof -
-      obtain n where n: "(derived H ^^ n) J = { \<one>\<^bsub>H\<^esub> }"
-        using A(4) H.solvable_imp_subgroup H.solvable_imp_trivial_derived_seq by blast
-      have "(derived H ^^ n) I \<subseteq> (derived H ^^ n) J"
-        using A by (simp add: H.mono_derived subgroupE(1))
-      hence "(derived H ^^ n) I \<subseteq> { \<one>\<^bsub>H\<^esub> }" using n by simp
-      hence "(derived H ^^ n) I = { \<one>\<^bsub>H\<^esub> }"
-        by (simp add: A(1) subgroupE(2)[OF H.exp_of_derived_is_subgroup] subset_singleton_iff)
-      thus ?thesis
-        using A(1) H.trivial_derived_seq_imp_solvable by blast 
-    qed } note aux_lemma = this
-
-  show ?thesis
-  proof (rule ccontr)
-    assume "\<not> \<not> solvable H"
-    hence "solvable_seq H (carrier H)" unfolding solvable_def by simp
-    hence "solvable_seq H (h ` (carrier G))"
-      using aux_lemma[of "h ` (carrier G)" "carrier H"]
-      by (metis G.generateI G.subgroupE(1) G.subgroup_self H.generateE(1)
-          H.subgroup_self generate_of_img hom_closed image_subsetI)
-    hence "solvable_seq G (carrier G)"
-      using G.subgroup_self assms(1) solvable_img_imp_solvable by blast
-    hence "solvable G" unfolding solvable_def by simp
-    thus False using assms(2) by simp
-  qed
+  obtain n where "(derived H ^^ n) (h ` K) = { \<one>\<^bsub>H\<^esub> }"
+    using solvable_imp_trivial_derived_seq assms(1,3) by auto
+  hence "h ` ((derived G ^^ n) K) = { \<one>\<^bsub>H\<^esub> }"
+    unfolding exp_of_derived_img[OF subgroup.subset[OF assms(1)]] .
+  moreover have "(derived G ^^ n) K \<subseteq> K"
+    using G.mono_derived[of _ K] G.derived_incl[OF _ assms(1)] by (induct n) (auto)
+  hence "inj_on h ((derived G ^^ n) K)"
+    using inj_on_subset[OF assms(2)] by blast
+  moreover have "{ \<one> } \<subseteq> (derived G ^^ n) K"
+    using subgroup.one_closed[OF G.exp_of_derived_is_subgroup[OF assms(1)]] by blast
+  ultimately show ?thesis
+    using G.trivial_derived_seq_imp_solvable[OF assms(1), of n]
+    by (metis (no_types, lifting) hom_one image_empty image_insert inj_on_image_eq_iff order_refl)
 qed
 
 corollary (in group_hom) inj_hom_imp_solvable:
-  assumes "inj_on h (carrier G)"
-  shows "solvable H \<Longrightarrow> solvable G"
-  using not_solvable[OF assms] by auto
+  assumes "inj_on h (carrier G)" and "solvable H" shows "solvable G"
+  using solvable_img_imp_solvable[OF _ assms(1)] G.subgroup_self
+        solvable_subgroup[OF subgroup_img_is_subgroup assms(2)]
+  unfolding solvable_def
+  by simp
 
 theorem (in group_hom) solvable_imp_solvable_img:
-  assumes "subgroup I G"
-    and "solvable_seq G I"
-  shows "solvable_seq H (h ` I)"
+  assumes "solvable_seq G K" shows "solvable_seq H (h ` K)"
 proof -
-  obtain n where "(derived G ^^ n) I = { \<one>\<^bsub>G\<^esub> }"
-    using G.solvable_imp_trivial_derived_seq[OF assms(2) assms(1)] ..
-  hence "(derived H ^^ n) (h ` I) = { \<one>\<^bsub>H\<^esub> }"
-    using derived_of_img[OF G.subgroupE(1)[OF assms(1)], of n] by simp
+  obtain n where "(derived G ^^ n) K = { \<one> }"
+    using G.solvable_imp_trivial_derived_seq[OF assms] by blast
   thus ?thesis
-    using H.trivial_derived_seq_imp_solvable[OF subgroup_img_is_subgroup[OF assms(1)]] by simp
+    using trivial_derived_seq_imp_solvable[OF subgroup_img_is_subgroup, of _ n]
+          exp_of_derived_img[OF subgroup.subset, of _ n] G.solvable_imp_subgroup[OF assms]
+    by auto
 qed
 
 corollary (in group_hom) surj_hom_imp_solvable:
-  assumes "h ` (carrier G) = (carrier H)"
-  shows "solvable G \<Longrightarrow> solvable H"
-  using solvable_imp_solvable_img[OF G.subgroup_self] assms unfolding solvable_def by auto
+  assumes "h ` carrier G = carrier H" and "solvable G" shows "solvable H"
+  using assms solvable_imp_solvable_img[of "carrier G"] unfolding solvable_def by simp
 
 lemma solvable_seq_condition:
-  assumes "group_hom G1 G2 h" "group_hom G2 G3 f"
-      and "subgroup I G1" "subgroup J G2"
-      and "h ` I \<subseteq> J"
-      and "\<And>g. \<lbrakk> g \<in> carrier G2; f g = \<one>\<^bsub>G3\<^esub> \<rbrakk> \<Longrightarrow> g \<in> h ` I"
-    shows "\<lbrakk> solvable_seq G1 I; solvable_seq G3 (f ` J) \<rbrakk> \<Longrightarrow> solvable_seq G2 J"
+  assumes "group_hom G H f" "group_hom H K g" and "f ` I \<subseteq> J" and "kernel H K g \<subseteq> f ` I"
+    and "subgroup J H" and "solvable_seq G I" "solvable_seq K (g ` J)"
+  shows "solvable_seq H J"
 proof -
-  have G1: "group G1" and G2: "group G2" and G3: "group G3"
-    using assms(1-2) unfolding group_hom_def by auto
+  interpret G: group G + H: group H + K: group K + J: subgroup J H + I: subgroup I G
+    using assms(1-2,5) group.solvable_imp_subgroup[OF _ assms(6)] unfolding group_hom_def by auto
 
-  assume "solvable_seq G1 I" "solvable_seq G3 (f ` J)"
-  then obtain n m :: nat
-    where n: "(derived G1 ^^ n) I       = { \<one>\<^bsub>G1\<^esub> }"
-      and m: "(derived G3 ^^ m) (f ` J) = { \<one>\<^bsub>G3\<^esub> }"
-    using group.solvable_imp_trivial_derived_seq[OF G1, of I]
-          group.solvable_imp_trivial_derived_seq[OF G3, of "f ` J"]
-          group_hom.subgroup_img_is_subgroup[OF assms(2) assms(4)] assms(2-4) by auto
-  have "f ` ((derived G2 ^^ m) J) = (derived G3 ^^ m) (f ` J)"
-    using group_hom.derived_of_img[OF assms(2), of J m] subgroup.subset[OF assms(4)] by simp
-  hence "f ` ((derived G2 ^^ m) J) = { \<one>\<^bsub>G3\<^esub> }"
-    using m by simp
-  hence "((derived G2 ^^ m) J) \<subseteq> h ` I"
-    using assms(6) group.exp_of_derived_in_carrier[OF G2 subgroup.subset[OF assms(4)], of m]
-    by blast
-  hence "(derived G2 ^^ n) ((derived G2 ^^ m) J) \<subseteq> (derived G2 ^^ n) (h ` I)"
-    using group.mono_derived[OF G2, of "h ` I" "(derived G2 ^^ m) J" n]
-          subgroup.subset[OF group_hom.subgroup_img_is_subgroup[OF assms(1) assms(3)]] by blast
-  also have " ... = h ` { \<one>\<^bsub>G1\<^esub> }"
-    using group_hom.derived_of_img[OF assms(1) subgroup.subset[OF assms(3)], of n] n by simp
-  also have " ... = { \<one>\<^bsub>G2\<^esub> }"
-    using assms(1) by (simp add: group_hom.hom_one)
-  finally have "(derived G2 ^^ n) ((derived G2 ^^ m) J) \<subseteq> { \<one>\<^bsub>G2\<^esub> }" .
-  hence "(derived G2 ^^ (n + m)) J \<subseteq> { \<one>\<^bsub>G2\<^esub> }"
-    by (metis comp_eq_dest_lhs funpow_add)
-  moreover have "{ \<one>\<^bsub>G2\<^esub> } \<subseteq> (derived G2 ^^ (n + m)) J"
-    using subgroup.one_closed[OF group.exp_of_derived_is_subgroup[OF G2 assms(4), of "n + m"]] by simp
+  obtain n m
+    where n: "(derived G ^^ n) I = { \<one>\<^bsub>G\<^esub> }" and m: "(derived K ^^ m) (g ` J) = { \<one>\<^bsub>K\<^esub> }"
+    using G.solvable_imp_trivial_derived_seq[OF assms(6)]
+          K.solvable_imp_trivial_derived_seq[OF assms(7)]
+    by auto
+  have "(derived H ^^ m) J \<subseteq> f ` I"
+    using m H.exp_of_derived_in_carrier[OF J.subset, of m] assms(4)
+    by (auto simp add: group_hom.exp_of_derived_img[OF assms(2) J.subset] kernel_def)
+  hence "(derived H ^^ n) ((derived H ^^ m) J) \<subseteq> f ` ((derived G ^^ n) I)"
+    using n H.mono_exp_of_derived unfolding sym[OF group_hom.exp_of_derived_img[OF assms(1) I.subset, of n]] by simp
+  hence "(derived H ^^ (n + m)) J \<subseteq> { \<one>\<^bsub>H\<^esub> }"
+    using group_hom.hom_one[OF assms(1)] unfolding n by (simp add: funpow_add)
+  moreover have "{ \<one>\<^bsub>H\<^esub> } \<subseteq> (derived H ^^ (n + m)) J"
+    using subgroup.one_closed[OF H.exp_of_derived_is_subgroup[OF assms(5), of "n + m"]] by blast
   ultimately show ?thesis
-    using group.trivial_derived_seq_imp_solvable[OF G2 assms(4), of "n + m"] by auto 
+    using H.trivial_derived_seq_imp_solvable[OF assms(5)] by simp
 qed
 
 lemma solvable_condition:
-  assumes "group_hom G1 G2 h" "group_hom G2 G3 f"
-      and "f ` (carrier G2) = (carrier G3)"
-      and "kernel G2 G3 f \<subseteq> h ` (carrier G1)"
-    shows "\<lbrakk> solvable G1; solvable G3 \<rbrakk> \<Longrightarrow> solvable G2"
-proof -
-  assume "solvable G1" "solvable G3"
-  moreover have "\<And>g. \<lbrakk> g \<in> carrier G2; f g = \<one>\<^bsub>G3\<^esub> \<rbrakk> \<Longrightarrow> g \<in> h ` (carrier G1)"
-    using assms(4) unfolding kernel_def by auto
-  moreover have "h ` (carrier G1 ) \<subseteq> (carrier G2)"
-    using group_hom.hom_closed[OF assms(1)] image_subsetI by blast
-  ultimately show ?thesis
-    using solvable_seq_condition[OF assms(1-2), of "carrier G1" "carrier G2"] assms(1-3)
-    unfolding solvable_def group_hom_def by (simp add: group.subgroup_self)
-qed
+  assumes "group_hom G H f" "group_hom H K g"
+    and "g ` (carrier H) = carrier K" and "kernel H K g \<subseteq> f ` (carrier G)"
+    and "solvable G" "solvable K" shows "solvable H"
+  using solvable_seq_condition[OF assms(1-2) _ assms(4) group.subgroup_self] assms(3,5-6)
+        subgroup.subset[OF group_hom.img_is_subgroup[OF assms(1)]] group_hom.axioms(2)[OF assms(1)]
+  by (simp add: solvable_def)
 
-end
+end
\ No newline at end of file
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Subrings.thy
--- a/src/HOL/Algebra/Subrings.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Subrings.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -377,6 +377,8 @@
   assumes "h \<in> ring_hom R S" and "subring K R"
   shows "ring (S \<lparr> carrier := h ` K, one := h \<one>, zero := h \<zero> \<rparr>)"
 proof -
+  have [simp]: "h \<one> = \<one>\<^bsub>S\<^esub>"
+    using assms ring_hom_one by blast
   have "ring (R \<lparr> carrier := K \<rparr>)"
     by (simp add: assms(2) subring_is_ring)
   moreover have "h \<in> ring_hom (R \<lparr> carrier := K \<rparr>) S"
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Sym_Groups.thy
--- a/src/HOL/Algebra/Sym_Groups.thy	Thu Oct 04 11:18:39 2018 +0200
+++ b/src/HOL/Algebra/Sym_Groups.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -3,32 +3,72 @@
 *)
 
 theory Sym_Groups
-  imports Cycles Group Coset Generated_Groups Solvable_Groups
+  imports Cycles Solvable_Groups
+
 begin
 
+section \<open>Symmetric Groups\<close>
+
+subsection \<open>Definitions\<close>
+
 abbreviation inv' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
   where "inv' f \<equiv> Hilbert_Choice.inv f"
   
 definition sym_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
   where "sym_group n = \<lparr> carrier = { p. p permutes {1..n} }, mult = (\<circ>), one = id \<rparr>"
 
+definition alt_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
+  where "alt_group n = (sym_group n) \<lparr> carrier := { p. p permutes {1..n} \<and> evenperm p } \<rparr>"
+
 definition sign_img :: "int monoid"
   where "sign_img = \<lparr> carrier = { -1, 1 }, mult = (*), one = 1 \<rparr>"
 
 
+subsection \<open>Basic Properties\<close>
+
+lemma sym_group_carrier: "p \<in> carrier (sym_group n) \<longleftrightarrow> p permutes {1..n}"
+  unfolding sym_group_def by simp
+
+lemma sym_group_mult: "mult (sym_group n) = (\<circ>)"
+  unfolding sym_group_def by simp
+
+lemma sym_group_one: "one (sym_group n) = id"
+  unfolding sym_group_def by simp
+
+lemma sym_group_carrier': "p \<in> carrier (sym_group n) \<Longrightarrow> permutation p"
+  unfolding sym_group_carrier permutation_permutes by auto
+
+lemma alt_group_carrier: "p \<in> carrier (alt_group n) \<longleftrightarrow> p permutes {1..n} \<and> evenperm p"
+  unfolding alt_group_def by auto
+
+lemma alt_group_mult: "mult (alt_group n) = (\<circ>)"
+  unfolding alt_group_def using sym_group_mult by simp
+
+lemma alt_group_one: "one (alt_group n) = id"
+  unfolding alt_group_def using sym_group_one by simp
+
+lemma alt_group_carrier': "p \<in> carrier (alt_group n) \<Longrightarrow> permutation p"
+  unfolding alt_group_carrier permutation_permutes by auto
+
 lemma sym_group_is_group: "group (sym_group n)"
-  apply (rule groupI)
-  apply (simp_all add: sym_group_def permutes_compose permutes_id comp_assoc)
-  using permutes_inv permutes_inv_o(2) by blast
+  using permutes_inv permutes_inv_o(2)
+  by (auto intro!: groupI
+         simp add: sym_group_def permutes_compose
+                   permutes_id comp_assoc, blast)
+
+lemma sign_img_is_group: "group sign_img"
+  unfolding sign_img_def by (unfold_locales, auto simp add: Units_def)
 
 lemma sym_group_inv_closed:
-  assumes "p \<in> carrier (sym_group n)"
-  shows "inv' p \<in> carrier (sym_group n)"
+  assumes "p \<in> carrier (sym_group n)" shows "inv' p \<in> carrier (sym_group n)"
   using assms permutes_inv sym_group_def by auto
 
-lemma sym_group_inv_equality:
-  assumes "p \<in> carrier (sym_group n)"
-  shows "inv\<^bsub>(sym_group n)\<^esub> p = inv' p"
+lemma alt_group_inv_closed:
+  assumes "p \<in> carrier (alt_group n)" shows "inv' p \<in> carrier (alt_group n)"
+  using evenperm_inv[OF alt_group_carrier'] permutes_inv assms alt_group_carrier by auto
+
+lemma sym_group_inv_equality [simp]:
+  assumes "p \<in> carrier (sym_group n)" shows "inv\<^bsub>(sym_group n)\<^esub> p = inv' p"
 proof -
   have "inv' p \<circ> p = id"
     using assms permutes_inv_o(2) sym_group_def by auto
@@ -38,54 +78,51 @@
     by (simp add: assms sym_group_inv_closed)
 qed
 
-lemma sign_is_hom:
-  "group_hom (sym_group n) sign_img sign"
-  unfolding group_hom_def
-proof (auto)
-  show "group (sym_group n)"
-    by (simp add: sym_group_is_group)
-next
-  show "group sign_img"
-    unfolding sign_img_def group_def monoid_def group_axioms_def Units_def by auto
-next
-  show "group_hom_axioms (sym_group n) sign_img sign"
-    unfolding sign_img_def group_hom_axioms_def sym_group_def hom_def
-  proof auto
-    show "\<And>x. sign x \<noteq> - 1 \<Longrightarrow> x permutes {Suc 0..n} \<Longrightarrow> sign x = 1"
-      by (meson sign_def)
-    show "\<And>x y. \<lbrakk> x permutes {Suc 0..n}; y permutes {Suc 0..n} \<rbrakk> \<Longrightarrow>
-                  sign (x \<circ> y) = sign x * sign y"
-      using sign_compose permutation_permutes by blast
-  qed
-qed
+lemma sign_is_hom: "sign \<in> hom (sym_group n) sign_img"
+  unfolding hom_def sign_img_def sym_group_mult using sym_group_carrier'[of _ n]
+  by (auto simp add: sign_compose, meson sign_def)
+
+lemma sign_group_hom: "group_hom (sym_group n) sign_img sign"
+  using group_hom.intro[OF sym_group_is_group sign_img_is_group] sign_is_hom
+  by (simp add: group_hom_axioms_def)
 
+lemma sign_is_surj:
+  assumes "n \<ge> 2" shows "sign ` (carrier (sym_group n)) = carrier sign_img"
+proof -
+  have "swapidseq (Suc 0) (Fun.swap (1 :: nat) 2 id)"
+    using comp_Suc[OF id, of "1 :: nat" "2"] by auto
+  hence "sign (Fun.swap (1 :: nat) 2 id) = (-1 :: int)"
+    by (simp add: sign_swap_id)
+  moreover have "Fun.swap (1 :: nat) 2 id \<in> carrier (sym_group n)" and "id \<in> carrier (sym_group n)"
+    using assms permutes_swap_id[of "1 :: nat" "{1..n}" 2] permutes_id
+    unfolding sym_group_carrier by auto
+  ultimately have "carrier sign_img \<subseteq> sign ` (carrier (sym_group n))"
+    using sign_id mk_disjoint_insert unfolding sign_img_def by fastforce
+  moreover have "sign ` (carrier (sym_group n)) \<subseteq> carrier sign_img"
+    using sign_is_hom unfolding hom_def by auto
+  ultimately show ?thesis
+    by blast
+qed 
 
-definition alt_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
-  where "alt_group n = (sym_group n) \<lparr> carrier := { p. p permutes {1..n} \<and> evenperm p } \<rparr>"
-
-lemma alt_group_is_kernel_from_sign:
+lemma alt_group_is_sign_kernel:
   "carrier (alt_group n) = kernel (sym_group n) sign_img sign"
   unfolding alt_group_def sym_group_def sign_img_def kernel_def sign_def by auto
 
-lemma alt_group_is_group:
-  "group (alt_group n)"
-proof -
-  have "subgroup (kernel (sym_group n) sign_img sign) (sym_group n)"
-    using group_hom.subgroup_kernel sign_is_hom by blast
-  thus ?thesis
-    using alt_group_def alt_group_is_kernel_from_sign group.subgroup_imp_group
-         sym_group_is_group by fastforce
-qed
+lemma alt_group_is_subgroup: "subgroup (carrier (alt_group n)) (sym_group n)"
+  using group_hom.subgroup_kernel[OF sign_group_hom]
+  unfolding alt_group_is_sign_kernel by blast
 
-lemma alt_group_inv_closed:
-  assumes "p \<in> carrier (alt_group n)"
-  shows "inv' p \<in> carrier (alt_group n)"
-  using assms permutes_inv alt_group_def
-  using evenperm_inv permutation_permutes by fastforce
+lemma alt_group_is_group: "group (alt_group n)"
+  using group.subgroup_imp_group[OF sym_group_is_group alt_group_is_subgroup]
+  by (simp add: alt_group_def)
+
+lemma sign_iso:
+  assumes "n \<ge> 2" shows "(sym_group n) Mod (carrier (alt_group n)) \<cong> sign_img"
+  using group_hom.FactGroup_iso[OF sign_group_hom sign_is_surj[OF assms]]
+  unfolding alt_group_is_sign_kernel .
 
 lemma alt_group_inv_equality:
-  assumes "p \<in> carrier (alt_group n)"
-  shows "inv\<^bsub>(alt_group n)\<^esub> p = inv' p"
+  assumes "p \<in> carrier (alt_group n)" shows "inv\<^bsub>(alt_group n)\<^esub> p = inv' p"
 proof -
   have "inv' p \<circ> p = id"
     using assms permutes_inv_o(2) alt_group_def by auto
@@ -95,52 +132,61 @@
     by (simp add: assms alt_group_inv_closed)
 qed
 
+lemma sym_group_card_carrier: "card (carrier (sym_group n)) = fact n"
+  using card_permutations[of "{1..n}" n] unfolding sym_group_def by simp
+
+lemma alt_group_card_carrier:
+  assumes "n \<ge> 2" shows "2 * card (carrier (alt_group n)) = fact n"
+proof -
+  have "card (rcosets\<^bsub>sym_group n\<^esub> (carrier (alt_group n))) = 2"
+    using iso_same_card[OF sign_iso[OF assms]] unfolding FactGroup_def sign_img_def by auto
+  thus ?thesis
+    using group.lagrange[OF sym_group_is_group alt_group_is_subgroup, of n]
+    unfolding order_def sym_group_card_carrier by simp
+qed
+
 
 subsection \<open>Transposition Sequences\<close>
 
 text \<open>In order to prove that the Alternating Group can be generated by 3-cycles, we need
       a stronger decomposition of permutations as transposition sequences than the one 
-      proposed found at Permutations.thy\<close>
+      proposed at Permutations.thy. \<close>
 
-inductive swapidseq_ext :: "'a set \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
-empty:  "swapidseq_ext {} 0 id" |
-single: "\<lbrakk> swapidseq_ext S n p; a \<notin> S \<rbrakk> \<Longrightarrow> swapidseq_ext (insert a S) n p" |
-comp:   "\<lbrakk> swapidseq_ext S n p; a \<noteq> b \<rbrakk> \<Longrightarrow>
-           swapidseq_ext (insert a (insert b S)) (Suc n) ((Fun.swap a b id) \<circ> p)"
+inductive swapidseq_ext :: "'a set \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
+  where
+    empty:  "swapidseq_ext {} 0 id"
+  | single: "\<lbrakk> swapidseq_ext S n p; a \<notin> S \<rbrakk> \<Longrightarrow> swapidseq_ext (insert a S) n p"
+  | comp:   "\<lbrakk> swapidseq_ext S n p; a \<noteq> b \<rbrakk> \<Longrightarrow>
+               swapidseq_ext (insert a (insert b S)) (Suc n) ((Fun.swap a b id) \<circ> p)"
 
 
 lemma swapidseq_ext_finite:
-  assumes "swapidseq_ext S n p"
-  shows "finite S" using assms
-  apply (induction) by auto
+  assumes "swapidseq_ext S n p" shows "finite S"
+  using assms by (induction) (auto)
+
+lemma swapidseq_ext_zero:
+  assumes "finite S" shows "swapidseq_ext S 0 id"
+  using assms empty by (induct set: "finite", fastforce, simp add: single)
+
+lemma swapidseq_ext_imp_swapidseq:
+  assumes "swapidseq_ext S n p" shows "swapidseq n p"
+  using assms by (induction, simp, simp, meson comp_Suc)
 
 lemma swapidseq_ext_zero_imp_id:
-  assumes "swapidseq_ext S 0 p"
-  shows "p = id"
+  assumes "swapidseq_ext S 0 p" shows "p = id"
 proof -
-  { fix S n and p :: "'a \<Rightarrow> 'a" assume "swapidseq_ext S n p" "n = 0"
-    hence "p = id"
-      apply (induction) by auto }
-  thus ?thesis using assms by auto
-qed
-
-lemma swapidseq_ext_zero:
-  assumes "finite S"
-  shows "swapidseq_ext S 0 id" using assms 
-proof (induct set: "finite")
-  case empty thus ?case using swapidseq_ext.empty .
-next
-  case insert show ?case using swapidseq_ext.single[OF insert(3) insert(2)] .
+  have "\<lbrakk> swapidseq_ext S n p; n = 0 \<rbrakk> \<Longrightarrow> p = id" for n
+    by (induction rule: swapidseq_ext.induct, auto)
+  thus ?thesis
+    using assms by simp
 qed
 
 lemma swapidseq_ext_finite_expansion:
-  assumes "finite B" "swapidseq_ext A n p"
-  shows "swapidseq_ext (A \<union> B) n p" using assms 
-proof (induct set: "finite")
-  case empty thus ?case by simp
-next
-  case insert show ?case
-    by (metis Un_insert_right insert.hyps(3) insert.prems insert_absorb single) 
+  assumes "finite B" and "swapidseq_ext A n p" shows "swapidseq_ext (A \<union> B) n p"
+  using assms
+proof (induct set: "finite", simp)
+  case (insert b B) show ?case
+    using insert single[OF insert(3), of b] by (metis Un_insert_right insert_absorb)
 qed
 
 lemma swapidseq_ext_backwards:
@@ -148,32 +194,40 @@
   shows "\<exists>a b A' p'. a \<noteq> b \<and> A = (insert a (insert b A')) \<and>
                      swapidseq_ext A' n p' \<and> p = (Fun.swap a b id) \<circ> p'"
 proof -
-  { fix A n k and p :: "'a \<Rightarrow> 'a" assume "swapidseq_ext A n p" "n = Suc k"
+  { fix A n k and p :: "'a \<Rightarrow> 'a"
+    assume "swapidseq_ext A n p" "n = Suc k"
     hence "\<exists>a b A' p'. a \<noteq> b \<and> A = (insert a (insert b A')) \<and>
                        swapidseq_ext A' k p' \<and> p = (Fun.swap a b id) \<circ> p'"
-    proof (induction)
-      case empty thus ?case by simp
-    next
+    proof (induction, simp)
       case single thus ?case
         by (metis Un_insert_right insert_iff insert_is_Un swapidseq_ext.single)
     next
-      case comp thus ?case by blast 
+      case comp thus ?case
+        by blast 
     qed }
-  thus ?thesis using assms by simp
+  thus ?thesis
+    using assms by simp
 qed
 
+lemma swapidseq_ext_backwards':
+  assumes "swapidseq_ext A (Suc n) p"
+  shows "\<exists>a b A' p'. a \<in> A \<and> b \<in> A \<and> a \<noteq> b \<and> swapidseq_ext A n p' \<and> p = (Fun.swap a b id) \<circ> p'"
+  using swapidseq_ext_backwards[OF assms] swapidseq_ext_finite_expansion
+  by (metis Un_insert_left assms insertI1 sup.idem sup_commute swapidseq_ext_finite)
+
 lemma swapidseq_ext_endswap:
   assumes "swapidseq_ext S n p" "a \<noteq> b"
-  shows "swapidseq_ext (insert a (insert b S)) (Suc n) (p \<circ> (Fun.swap a b id))" using assms
+  shows "swapidseq_ext (insert a (insert b S)) (Suc n) (p \<circ> (Fun.swap a b id))"
+  using assms
 proof (induction n arbitrary: S p a b)
   case 0 hence "p = id"
     using swapidseq_ext_zero_imp_id by blast
-  thus ?case using 0 by (metis comp_id id_comp swapidseq_ext.comp) 
+  thus ?case
+    using 0 by (metis comp_id id_comp swapidseq_ext.comp) 
 next
   case (Suc n)
   then obtain c d S' and p' :: "'a \<Rightarrow> 'a"
-    where cd: "c \<noteq> d"
-      and S: "S = (insert c (insert d S'))" "swapidseq_ext S' n p'"
+    where cd: "c \<noteq> d" and S: "S = (insert c (insert d S'))" "swapidseq_ext S' n p'"
       and p: "p = (Fun.swap c d id) \<circ> p'"
     using swapidseq_ext_backwards[OF Suc(2)] by blast
   hence "swapidseq_ext (insert a (insert b S')) (Suc n) (p' \<circ> (Fun.swap a b id))"
@@ -181,83 +235,43 @@
   hence "swapidseq_ext (insert c (insert d (insert a (insert b S')))) (Suc (Suc n))
                  ((Fun.swap c d id) \<circ> p' \<circ> (Fun.swap a b id))"
     by (metis cd fun.map_comp swapidseq_ext.comp)
-  then show ?case by (metis S(1) p insert_commute) 
-qed
-
-lemma swapidseq_ext_imp_swapiseq:
-  assumes "swapidseq_ext S n p"
-  shows "swapidseq n p" using assms
-proof (induction)
-  case empty thus ?case by simp
-  case single show ?case using single(3) .
-next
-  case comp thus ?case by (meson comp_Suc) 
+  thus ?case
+    by (metis S(1) p insert_commute) 
 qed
 
 lemma swapidseq_ext_extension:
-  assumes "swapidseq_ext A n p" "swapidseq_ext B m q" "A \<inter> B = {}"
+  assumes "swapidseq_ext A n p" and "swapidseq_ext B m q" and "A \<inter> B = {}"
   shows "swapidseq_ext (A \<union> B) (n + m) (p \<circ> q)"
-proof -
-  { fix m and q :: "'a \<Rightarrow> 'a" and A B :: "'a set" assume "finite A" "swapidseq_ext B m q"
-    hence "swapidseq_ext (A \<union> B) m q"
-    proof (induct set: "finite")
-      case empty thus ?case by simp
-    next
-      case (insert a A') thus ?case
-        using swapidseq_ext.single[of "A' \<union> B" m q a]
-        by (metis Un_insert_left insert_absorb) 
-    qed } note aux_lemma = this
-
-  from assms show ?thesis
-  proof (induct n arbitrary: p A)
-    case 0 thus ?case
-      using swapidseq_ext_zero_imp_id[OF 0(1)] aux_lemma[of A B m q] by (simp add: swapidseq_ext_finite)
-  next
-    case (Suc n)
-    obtain a b A' and p' :: "'a \<Rightarrow> 'a"
-      where A': "a \<noteq> b" "A = (insert a (insert b A'))"
-        and p': "swapidseq_ext A' n p'"
-        and p: "p = (Fun.swap a b id) \<circ> p'"
-      using swapidseq_ext_backwards[OF Suc(2)] by blast
-    hence "swapidseq_ext (A' \<union> B) (n + m) (p' \<circ> q)"
-      using Suc.hyps Suc.prems(3) assms(2) by fastforce
-    thus ?case using swapidseq_ext.comp[of "A' \<union> B" "n + m" "p' \<circ> q" a b]
-      by (metis Un_insert_left p A' add_Suc rewriteR_comp_comp)
-  qed
+  using assms(1,3)
+proof (induction, simp add: assms(2))
+  case single show ?case
+    using swapidseq_ext.single[OF single(3)] single(2,4) by auto
+next
+  case comp show ?case
+    using swapidseq_ext.comp[OF comp(3,2)] comp(4)
+    by (metis Un_insert_left add_Suc insert_disjoint(1) o_assoc)
 qed
 
 lemma swapidseq_ext_of_cycles:
-  assumes "cycle cs"
-  shows "swapidseq_ext (set cs) (length cs - 1) (cycle_of_list cs)" using assms
-proof (induction cs rule: cycle_of_list.induct)
+  assumes "cycle cs" shows "swapidseq_ext (set cs) (length cs - 1) (cycle_of_list cs)"
+  using assms
+proof (induct cs rule: cycle_of_list.induct)
   case (1 i j cs) show ?case
-  proof (cases)
-    assume "cs = []" thus ?case
-      using swapidseq_ext.comp[OF swapidseq_ext.empty, of i j] "1.prems" by auto 
-  next
-    assume "cs \<noteq> []" hence "length (j # cs) \<ge> 2"
-      using not_less_eq_eq by fastforce
-    hence IH: "swapidseq_ext (set (j # cs)) (length (j # cs) - 1) (cycle_of_list (j # cs))"
-      using "1.IH" "1.prems" by auto
-    thus ?case using swapidseq_ext.comp[OF IH, of i j]
-      by (metis "1.prems" cycle_of_list.simps(1) diff_Suc_1 distinct.simps(2)
-          distinct_length_2_or_more insert_absorb length_Cons list.simps(15))
-  qed
+    using comp[OF 1(1), of i j] 1(2) by (simp add: o_def)  
 next
-  case "2_1" thus ?case using swapidseq_ext.empty
-    by (metis cycle_of_list.simps(2) diff_0_eq_0 empty_set list.size(3)) 
+  case "2_1" show ?case
+    by (simp, metis eq_id_iff empty)
 next
-  case ("2_2" v) thus ?case using swapidseq_ext.single[OF swapidseq_ext.empty, of v]
-    by (metis cycle_of_list.simps(3) diff_Suc_1 distinct.simps(2)
-              empty_set length_Cons list.simps(15) list.size(3))
+  case ("2_2" v) show ?case
+    using single[OF empty, of v] by (simp, metis eq_id_iff)
 qed
 
 lemma cycle_decomp_imp_swapidseq_ext:
-  assumes "cycle_decomp S p"
-  shows "\<exists>n. swapidseq_ext S n p" using assms
+  assumes "cycle_decomp S p" shows "\<exists>n. swapidseq_ext S n p"
+  using assms
 proof (induction)
-  case empty
-  then show ?case using swapidseq_ext.empty by blast
+  case empty show ?case
+    using swapidseq_ext.empty by blast
 next
   case (comp I p cs)
   then obtain m where m: "swapidseq_ext I m p" by blast
@@ -267,415 +281,274 @@
     using comp.hyps(3) by blast
 qed
 
-lemma swapidseq_ext_of_permutations:
-  assumes "p permutes S" "finite S"
-  shows "\<exists>n. swapidseq_ext S n p"
-  using assms cycle_decomp_imp_swapidseq_ext cycle_decomposition by blast
-
-lemma split_swapidseq:
-  assumes "k \<le> n" "swapidseq n p"
-  shows "\<exists>q r. swapidseq k q \<and> swapidseq (n - k) r \<and> p = q \<circ> r"
-proof -
-  { fix n :: "nat" and p :: "'a \<Rightarrow> 'a" assume "swapidseq (Suc n) p"
-    hence "\<exists>a b q. a \<noteq> b \<and> swapidseq n q \<and> p = (Fun.swap a b id) \<circ> q"
-    proof (cases)
-      case comp_Suc thus ?thesis by auto
-    qed } note aux_lemma = this
-
-  from assms show ?thesis
-  proof (induction k)
-    case 0 thus ?case by simp
-  next
-    case (Suc k)
-    then obtain r q where 1: "swapidseq k q" "swapidseq (n - k) r" "p = q \<circ> r"
-      using Suc_leD by blast
-    then obtain a b r' where 2: "a \<noteq> b" "swapidseq (n - (Suc k)) r'" "r = (Fun.swap a b id) \<circ> r'"
-      using aux_lemma[of "n - (Suc k)" r] by (metis Suc.prems(1) Suc_diff_le diff_Suc_Suc)
-    have "swapidseq (Suc k) (q \<circ> (Fun.swap a b id))" using 1 2 by (simp add: swapidseq_endswap)
-    moreover have "p = (q \<circ> (Fun.swap a b id)) \<circ> r'"
-      using 1 2 fun.map_comp by blast 
-    ultimately show ?case using 2 by blast 
-  qed
-qed
+lemma swapidseq_ext_of_permutation:
+  assumes "p permutes S" and "finite S" shows "\<exists>n. swapidseq_ext S n p"
+  using cycle_decomp_imp_swapidseq_ext[OF cycle_decomposition[OF assms]] .
 
 lemma split_swapidseq_ext:
-  assumes "k \<le> n" "swapidseq_ext S n p"
-  shows "\<exists>q r S1 S2. swapidseq_ext S1 k q \<and> swapidseq_ext S2 (n - k) r \<and> p = q \<circ> r \<and> S1 \<union> S2 = S"
-  using assms
-proof (induction k)
-  case 0 have "finite S"
-    using "0.prems"(2) swapidseq_ext_finite by auto
-  have "swapidseq_ext {} 0 id \<and> swapidseq_ext S (n - 0) p \<and> p = id \<circ> p"
-    using swapidseq_ext.empty by (simp add: assms(2)) 
-  thus ?case by blast
-next
-  case (Suc k)
-  then obtain q r S1 S2 where "swapidseq_ext S1 k q" "swapidseq_ext S2 (n - k) r" "p = q \<circ> r" "S1 \<union> S2 = S"
-    using Suc_leD by blast
-  then obtain a b S2' and r' :: "'a \<Rightarrow> 'a"
-    where S2': "a \<noteq> b" "S2 = (insert a (insert b S2'))"
-      and  r': "swapidseq_ext S2' (n - (Suc k)) r'"
-      and   r: "r = (Fun.swap a b id) \<circ> r'"
-    by (metis Suc.prems(1) Suc_diff_le diff_Suc_Suc swapidseq_ext_backwards)
-   have "swapidseq_ext (insert a (insert b S1)) (Suc k) (q \<circ> (Fun.swap a b id))"
-    by (simp add: S2'(1) \<open>swapidseq_ext S1 k q\<close> swapidseq_ext_endswap)
-  moreover have "p = (q \<circ> (Fun.swap a b id)) \<circ> r'"
-    by (simp add: \<open>p = q \<circ> r\<close> fun.map_comp r)
-  moreover have "(insert a (insert b S1)) \<union> S2' = S"
-    using S2'(2) \<open>S1 \<union> S2 = S\<close> by auto
-  ultimately show ?case using r r' by blast
+  assumes "k \<le> n" and "swapidseq_ext S n p"
+  obtains q r U V where "swapidseq_ext U (n - k) q" and "swapidseq_ext V k r" and "p = q \<circ> r" and "U \<union> V = S"
+proof -
+  from assms
+  have "\<exists>q r U V. swapidseq_ext U (n - k) q \<and> swapidseq_ext V k r \<and> p = q \<circ> r \<and> U \<union> V = S"
+   (is "\<exists>q r U V. ?split k q r U V")
+  proof (induct k rule: inc_induct)
+    case base thus ?case
+      by (metis diff_self_eq_0 id_o sup_bot.left_neutral empty)
+  next
+    case (step m)
+    then obtain q r U V
+      where q: "swapidseq_ext U (n - Suc m) q" and r: "swapidseq_ext V (Suc m) r"
+        and p: "p = q \<circ> r" and S: "U \<union> V = S"
+      by blast
+    obtain a b r' V' 
+      where "a \<noteq> b" and r': "V = (insert a (insert b V'))" "swapidseq_ext V' m r'" "r = (Fun.swap a b id) \<circ> r'"
+      using swapidseq_ext_backwards[OF r] by blast
+    have "swapidseq_ext (insert a (insert b U)) (n - m) (q \<circ> (Fun.swap a b id))"
+      using swapidseq_ext_endswap[OF q \<open>a \<noteq> b\<close>] step(2) by (metis Suc_diff_Suc)
+    hence "?split m (q \<circ> (Fun.swap a b id)) r' (insert a (insert b U)) V'"
+      using r' S unfolding p by fastforce 
+    thus ?case by blast
+  qed
+  thus ?thesis
+    using that by blast
 qed
 
 
+subsection \<open>Unsolvability of Symmetric Groups\<close>
 
-definition three_cycles :: "nat \<Rightarrow> (nat \<Rightarrow> nat) set"
+text \<open>We show that symmetric groups (@{term\<open>sym_group n\<close>}) are unsolvable for @{term\<open>n \<ge> 5\<close>}.\<close>
+
+abbreviation three_cycles :: "nat \<Rightarrow> (nat \<Rightarrow> nat) set"
   where "three_cycles n \<equiv>
            { cycle_of_list cs | cs. cycle cs \<and> length cs = 3 \<and> set cs \<subseteq> {1..n} }"
 
 
 lemma stupid_lemma:
-  assumes "length cs = 3"
-  shows "cs = [(cs ! 0), (cs ! 1), (cs ! 2)]"
-proof (intro nth_equalityI)
-  show "length cs = length [(cs ! 0), (cs ! 1), (cs ! 2)]"
-    using assms by simp
-  show "\<And>i. i < length cs \<Longrightarrow> cs ! i = [(cs ! 0), (cs ! 1), (cs ! 2)] ! i"
-    by (metis Suc_1 Suc_eq_plus1 add.left_neutral assms less_antisym
-        less_one nth_Cons' nth_Cons_Suc numeral_3_eq_3)
+  assumes "length cs = 3" shows "cs = [ (cs ! 0), (cs ! 1), (cs ! 2) ]"
+  using assms by (auto intro!: nth_equalityI)
+    (metis Suc_lessI less_2_cases not_less_eq nth_Cons_0
+           nth_Cons_Suc numeral_2_eq_2 numeral_3_eq_3)
+
+lemma three_cycles_incl: "three_cycles n \<subseteq> carrier (alt_group n)"
+proof
+  fix p assume "p \<in> three_cycles n"
+  then obtain cs where cs: "p = cycle_of_list cs" "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
+    by auto
+  obtain a b c where cs_def: "cs = [ a, b, c ]"
+    using stupid_lemma[OF cs(3)] by auto
+  have "swapidseq (Suc (Suc 0)) ((Fun.swap a b id) \<circ> (Fun.swap b c id))"
+    using comp_Suc[OF comp_Suc[OF id], of b c a b] cs(2) unfolding cs_def by simp
+  hence "evenperm p"
+    using cs(1) unfolding cs_def by (simp add: evenperm_unique)
+  thus "p \<in> carrier (alt_group n)"
+    using permutes_subset[OF cycle_permutes cs(4)]
+    unfolding alt_group_carrier cs(1) by simp
 qed
 
-lemma alt_group_as_three_cycles:
+lemma alt_group_carrier_as_three_cycles:
   "carrier (alt_group n) = generate (alt_group n) (three_cycles n)"
-proof
-  show "generate (alt_group n) (three_cycles n) \<subseteq> carrier (alt_group n)"
-  proof
-    { fix p assume "p \<in> three_cycles n"
-      have "p \<in> carrier (alt_group n)"
-      proof -
-        from \<open>p \<in> three_cycles n\<close>
-        obtain cs where p: "p = cycle_of_list cs"
-                    and cs: "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
-          using three_cycles_def by blast
-        hence "p = (Fun.swap (cs ! 0) (cs ! 1) id) \<circ> (Fun.swap (cs ! 1) (cs ! 2) id)"
-          using stupid_lemma[OF cs(2)] p
-          by (metis comp_id cycle_of_list.simps(1) cycle_of_list.simps(3)) 
-
-        hence "evenperm p"
-          by (metis cs(1) distinct_length_2_or_more evenperm_comp
-                    evenperm_swap permutation_swap_id stupid_lemma[OF cs(2)])
-
-        moreover have "permutation p" using p cs(1) cycle_permutes by simp
-        hence "p permutes {1..n}"
-          using id_outside_supp[OF cs(1)] p cs permutation_permutes unfolding permutes_def
-          using permutation_permutes permutes_def subsetCE by metis
-
-        ultimately show ?thesis by (simp add: alt_group_def)
-      qed } note aux_lemma = this
+proof -
+  interpret A: group "alt_group n"
+    using alt_group_is_group by simp
 
-    fix p assume "p \<in> generate (alt_group n) (three_cycles n)"
-    thus "p \<in> carrier (alt_group n)"
-    proof (induction)
-      case one thus ?case by (simp add: alt_group_is_group group.is_monoid) 
-      case incl thus ?case using aux_lemma unfolding alt_group_def by auto
-      case inv thus ?case using aux_lemma by (simp add: alt_group_is_group) next
-      case eng thus ?case by (simp add: alt_group_is_group group.is_monoid monoid.m_closed) 
-    qed
-  qed
-
-next
-  show "carrier (alt_group n) \<subseteq> generate (alt_group n) (three_cycles n)"
+  show ?thesis
   proof
-    fix p assume p: "p \<in> carrier (alt_group n)"
-    show "p \<in> generate (alt_group n) (three_cycles n)"
-    proof -
+    show "generate (alt_group n) (three_cycles n) \<subseteq> carrier (alt_group n)"
+      using A.generate_subgroup_incl[OF three_cycles_incl A.subgroup_self] .
+  next
+    show "carrier (alt_group n) \<subseteq> generate (alt_group n) (three_cycles n)"
+    proof
       { fix q :: "nat \<Rightarrow> nat" and a b c
-        assume A: "a \<noteq> b" "b \<noteq> c" "{ a, b, c } \<subseteq> {1..n}" "q = cycle_of_list [a, b, c]" 
-        have "q \<in> generate (alt_group n) (three_cycles n)"
+        assume "a \<noteq> b" "b \<noteq> c" "{ a, b, c } \<subseteq> {1..n}" 
+        have "cycle_of_list [a, b, c] \<in> generate (alt_group n) (three_cycles n)"
         proof (cases)
-          assume "c = a" hence "q = id" by (simp add: A(4) swap_commute)
-          thus "q \<in> generate (alt_group n) (three_cycles n)"
-            using generate.one[of "alt_group n"] by (simp add: alt_group_def sym_group_def)
+          assume "c = a"
+          hence "cycle_of_list [ a, b, c ] = id"
+            by (simp add: swap_commute)
+          thus "cycle_of_list [ a, b, c ] \<in> generate (alt_group n) (three_cycles n)"
+            using one[of "alt_group n"] unfolding alt_group_one by simp
         next
-          assume "c \<noteq> a" 
-          have "q \<in> (three_cycles n)"
-            unfolding three_cycles_def mem_Collect_eq
-          proof (intro exI conjI)
-            show "cycle [a,b,c]"
-              using A \<open>c \<noteq> a\<close> by auto
-          qed (use A in auto)
-          thus "q \<in> generate (alt_group n) (three_cycles n)"
-            by (simp add: generate.incl)
-        qed } note gen3 = this
-      
-      { fix S :: "nat set" and q :: "nat \<Rightarrow> nat" assume A: "swapidseq_ext S 2 q" "S \<subseteq> {1..n}"
+          assume "c \<noteq> a"
+          have "distinct [a, b, c]"
+            using \<open>a \<noteq> b\<close> and \<open>b \<noteq> c\<close> and \<open>c \<noteq> a\<close> by auto
+          with \<open>{ a, b, c } \<subseteq> {1..n}\<close>
+          show "cycle_of_list [ a, b, c ] \<in> generate (alt_group n) (three_cycles n)"
+            by (intro incl, fastforce)
+        qed } note aux_lemma1 = this
+    
+      { fix S :: "nat set" and q :: "nat \<Rightarrow> nat"
+        assume seq: "swapidseq_ext S (Suc (Suc 0)) q" and S: "S \<subseteq> {1..n}"
         have "q \<in> generate (alt_group n) (three_cycles n)"
         proof -
-          obtain a b S' q' where ab: "a \<noteq> b" "S = (insert a (insert b S'))"
-                             and q': "swapidseq_ext S' 1 q'" "q = (Fun.swap a b id) \<circ> q'"
-            using swapidseq_ext_backwards[of S 1 q] A(1) Suc_1 by metis
-          then obtain c d S'' where cd: "c \<noteq> d" "S' = (insert c (insert d S''))"
-                                and q: "q = (Fun.swap a b id) \<circ> (Fun.swap c d id)"
-            using swapidseq_ext_backwards[of S' 0 q']
-            by (metis One_nat_def comp_id swapidseq_ext_zero_imp_id)
-          hence incl: "{ a, b, c, d } \<subseteq> {1..n}" using A(2) ab(2) by blast
+          obtain a b q' where ab: "a \<noteq> b" "a \<in> S" "b \<in> S"
+            and q': "swapidseq_ext S (Suc 0) q'" "q = (Fun.swap a b id) \<circ> q'"
+            using swapidseq_ext_backwards'[OF seq] by auto 
+          obtain c d where cd: "c \<noteq> d" "c \<in> S" "d \<in> S"
+            and q: "q = (Fun.swap a b id) \<circ> (Fun.swap c d id)"
+            using swapidseq_ext_backwards'[OF q'(1)]
+                  swapidseq_ext_zero_imp_id
+            unfolding q'(2)
+            by fastforce
+
+          consider (eq) "b = c" | (ineq) "b \<noteq> c" by auto
           thus ?thesis
-          proof (cases)
-            assume Eq: "b = c" hence "q = cycle_of_list [a, b, d]" by (simp add: q)
-            thus ?thesis using gen3 ab cd Eq incl by simp
+          proof cases
+            case eq then have "q = cycle_of_list [ a, b, d ]"
+              unfolding q by simp
+            moreover have "{ a, b, d } \<subseteq> {1..n}"
+              using ab cd S by blast
+            ultimately show ?thesis
+              using aux_lemma1[OF ab(1)] cd(1) eq by simp
           next
-            assume In: "b \<noteq> c"
-            have "q = (cycle_of_list [a, b, c]) \<circ> (cycle_of_list [b, c, d])"
-              by (metis (no_types, lifting) comp_id cycle_of_list.simps(1)
-                  cycle_of_list.simps(3) fun.map_comp q swap_id_idempotent)
-            moreover have "... = cycle_of_list [a, b, c] \<otimes>\<^bsub>alt_group n\<^esub> cycle_of_list [b, c, d]"
-              by (simp add: alt_group_def sym_group_def)
+            case ineq
+            hence "q = cycle_of_list [ a, b, c ] \<circ> cycle_of_list [ b, c, d ]"
+              unfolding q by (simp add: comp_swap)
+            moreover have "{ a, b, c } \<subseteq> {1..n}" and "{ b, c, d } \<subseteq> {1..n}"
+              using ab cd S by blast+
             ultimately show ?thesis
-              by (metis (no_types) In generate.eng[where ?h1.0 = "cycle_of_list [a, b, c]"
-                    and ?h2.0 = "cycle_of_list [b, c, d]"]
-                  gen3[of a b c] gen3[of b c d] \<open>a \<noteq> b\<close> \<open>c \<noteq> d\<close> insert_subset incl)
+              using eng[OF aux_lemma1[OF ab(1) ineq] aux_lemma1[OF ineq cd(1)]]
+              unfolding alt_group_mult by simp
           qed
-        qed } note gen3swap = this
+        qed } note aux_lemma2 = this
       
-      have "p permutes {1..n}"
-        using p permutation_permutes unfolding alt_group_def by auto
-      then obtain l where "swapidseq_ext {1..n} l p" "swapidseq l p"
-        using swapidseq_ext_of_permutations swapidseq_ext_imp_swapiseq by blast
-
-      have "evenperm p" using p by (simp add: alt_group_def)
-      hence "even l" using \<open>swapidseq l p\<close> evenperm_unique by blast
-
-      then obtain k where "swapidseq_ext {1..n} (2 * k) p"
-        using dvd_def by (metis \<open>swapidseq_ext {1..n} l p\<close>)
-      thus "p \<in> generate (alt_group n) (three_cycles n)"
+      fix p assume "p \<in> carrier (alt_group n)" then have p: "p permutes {1..n}" "evenperm p"
+        unfolding alt_group_carrier by auto
+      obtain m where m: "swapidseq_ext {1..n} m p"
+        using swapidseq_ext_of_permutation[OF p(1)] by auto
+      have "even m"
+        using swapidseq_ext_imp_swapidseq[OF m] p(2) evenperm_unique by blast
+      then obtain k where k: "m = 2 * k"
+        by auto
+      show "p \<in> generate (alt_group n) (three_cycles n)"
+        using m unfolding k
       proof (induct k arbitrary: p)
-        case 0
-        hence "p = id" by (simp add: swapidseq_ext_zero_imp_id) 
-        moreover have "id \<in> generate (alt_group n) (three_cycles n)"
-          using generate.one[of "alt_group n"] by (simp add: alt_group_def sym_group_def) 
-        ultimately show ?case by blast
+        case 0 then have "p = id"
+          using swapidseq_ext_zero_imp_id by simp
+        show ?case
+          using generate.one[of "alt_group n" "three_cycles n"]
+          unfolding alt_group_one \<open>p = id\<close> .
       next
-        case (Suc k)
-        then obtain S1 S2 q r
-          where split: "swapidseq_ext S1 2 q" "swapidseq_ext S2 (2 * k) r" "p = q \<circ> r" "S1 \<union> S2 = {1..n}"
-          using split_swapidseq_ext[of 2 "2 * Suc k" "{1..n}" p]  by auto
-
-        hence "r \<in> generate (alt_group n) (three_cycles n)"
-          using Suc.hyps swapidseq_ext_finite_expansion[of "{1..n}" S2 "2 * k" r]
-          by (metis (no_types, lifting) Suc.prems Un_commute sup.right_idem swapidseq_ext_finite)
-
-        moreover have "q \<in> generate (alt_group n) (three_cycles n)"
-          using gen3swap[OF split(1)] \<open>S1 \<union> S2 = {1..n}\<close> by auto
-        ultimately show ?case
-          using split generate.eng[of q "alt_group n" "three_cycles n" r]
-          by (metis (full_types) alt_group_def monoid.simps(1) partial_object.simps(3) sym_group_def)
+        case (Suc m)
+        have arith: "2 * (Suc m) - (Suc (Suc 0)) = 2 * m" and "Suc (Suc 0) \<le> 2 * Suc m"
+          by auto
+        then obtain q r U V
+          where q: "swapidseq_ext U (2 * m) q" and r: "swapidseq_ext V (Suc (Suc 0)) r"
+            and p: "p = q \<circ> r" and UV: "U \<union> V = {1..n}"
+          using split_swapidseq_ext[OF _ Suc(2), of "Suc (Suc 0)"] unfolding arith by metis
+        have "swapidseq_ext {1..n} (2 * m) q"
+          using UV q swapidseq_ext_finite_expansion[OF swapidseq_ext_finite[OF r] q] by simp
+        thus ?case
+          using eng[OF Suc(1) aux_lemma2[OF r], of q] UV unfolding alt_group_mult p by blast
       qed
     qed
   qed
 qed
 
-lemma elts_from_card:
-  assumes "card S \<ge> n"
-  obtains f where "inj_on f {1..n}" "f ` {1..n} \<subseteq> S"
-proof -
-  have "\<exists>f. inj_on f {1..n} \<and> f ` {1..n} \<subseteq> S" using assms
-  proof (induction n)
-    case 0 thus ?case by simp
-  next
-    case (Suc n)
-    then obtain f where f: "inj_on f {1..n}" "f ` {1..n} \<subseteq> S"
-      using Suc_leD by blast
-    hence "card (f ` {1..n}) = n" by (simp add: card_image)
-    then obtain y where y: "y \<in> S - (f ` {1..n})"
-      by (metis Diff_eq_empty_iff Suc.prems \<open>f ` {1..n} \<subseteq> S\<close> not_less_eq_eq order_refl some_in_eq subset_antisym)
-    define f' where f': "f' = (\<lambda>x. (if x \<in> {1..n} then f x else y))"
-    hence "\<And>i j. \<lbrakk> i \<in> {1..Suc n}; j \<in> {1..Suc n} \<rbrakk> \<Longrightarrow> f' i = f' j \<Longrightarrow> i = j"
-      by (metis (no_types, lifting) DiffD2 f(1) y atLeastAtMostSuc_conv atLeastatMost_empty_iff2
-          card_0_eq card_atLeastAtMost diff_Suc_1 finite_atLeastAtMost image_eqI inj_onD insertE nat.simps(3))
-    moreover have "f' ` {1..n} \<subseteq> S \<and> f' (Suc n) \<in> S"
-      using f f' y by (simp add: image_subset_iff)
-    hence "f' ` {1..Suc n} \<subseteq> S" using f' by auto 
-    ultimately show ?case unfolding inj_on_def by blast  
-  qed
-  thus ?thesis using that by auto
-qed
-
-theorem derived_alt_group_is_cons:
-  assumes "n \<ge> 5"
-  shows "derived (alt_group n) (carrier (alt_group n)) = carrier (alt_group n)"
+theorem derived_alt_group_const:
+  assumes "n \<ge> 5" shows "derived (alt_group n) (carrier (alt_group n)) = carrier (alt_group n)"
 proof
   show "derived (alt_group n) (carrier (alt_group n)) \<subseteq> carrier (alt_group n)"
-    by (simp add: alt_group_is_group group.derived_incl group.subgroup_self)
+    using group.derived_in_carrier[OF alt_group_is_group] by simp
 next
-  show "carrier (alt_group n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
-  proof -
-    have derived_set_in_carrier:
-      "derived_set (alt_group n) (carrier (alt_group n)) \<subseteq> carrier (alt_group n)"
-    proof
-      fix p assume "p \<in> derived_set (alt_group n) (carrier (alt_group n))"
-      then obtain q r
-        where q: "q \<in> carrier (alt_group n)"
-          and r: "r \<in> carrier (alt_group n)"
-          and "p = q \<otimes>\<^bsub>(alt_group n)\<^esub> r \<otimes>\<^bsub>(alt_group n)\<^esub> (inv' q) \<otimes>\<^bsub>(alt_group n)\<^esub> (inv' r)"
-        using alt_group_inv_equality by auto
-      hence p: "p = q \<circ> r \<circ> (inv' q) \<circ> (inv' r)"
-        by (simp add: alt_group_def sym_group_def)
-
-      have "q permutes {1..n}" using q by (simp add: alt_group_def)
-      moreover have r_perm: "r permutes {1..n}" using r by (simp add: alt_group_def)
-      ultimately have "p permutes {1..n} \<and> evenperm p" using p
-        apply (simp add: permutes_compose permutes_inv)
-        by (metis evenperm_comp evenperm_inv finite_atLeastAtMost
-            permutation_compose permutation_inverse permutation_permutes) 
-      thus "p \<in> carrier (alt_group n)" by (simp add: alt_group_def)
-    qed
+  { fix p assume "p \<in> three_cycles n" have "p \<in> derived (alt_group n) (carrier (alt_group n))"
+    proof -
+      obtain cs where cs: "p = cycle_of_list cs" "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
+        using \<open>p \<in> three_cycles n\<close> by auto
+      then obtain a b c where cs_def: "cs = [ a, b, c ]"
+        using stupid_lemma[OF cs(3)] by blast
+      have "card (set cs) = 3"
+        using cs(2-3)
+        by (simp add: distinct_card)
 
-    have "three_cycles n \<subseteq> derived_set (alt_group n) (carrier (alt_group n))"
-    proof
-      fix p :: "nat \<Rightarrow> nat" assume "p \<in> three_cycles n"
-      then obtain cs
-        where cs: "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}" and p: "p = cycle_of_list cs"
-        unfolding three_cycles_def by blast
-      then obtain i j k where i: "i = cs ! 0" and j: "j = cs ! 1" and k: "k = cs ! 2"
-                          and ijk: "cs = [i, j, k]" using stupid_lemma[OF cs(2)] by blast
+      have "set cs \<noteq> {1..n}"
+        using assms cs(3) unfolding sym[OF distinct_card[OF cs(2)]] by auto
+      then obtain d where d: "d \<notin> set cs" "d \<in> {1..n}"
+        using cs(4) by blast
 
-      have "p ^^ 2 = cycle_of_list [i, k, j]"
-      proof
-        fix l show "(p ^^ 2) l = cycle_of_list [i, k, j] l"
-        proof (cases)
-          assume "l \<notin> {i, j, k}"
-          hence "l \<notin> set cs \<and> l \<notin> set [i, k, j]" using ijk by auto
-          thus ?thesis
-            using id_outside_supp[of cs l] id_outside_supp[of "[i, j, k]" l] p o_apply
-            by (simp add: ijk numeral_2_eq_2)
-        next
-          assume "\<not> l \<notin> {i, j, k}" hence "l \<in> {i, j, k}" by simp
-          have "map ((cycle_of_list cs) ^^ 2) cs = rotate 2 cs"
-            using cyclic_rotation[of cs 2] cs by simp
-          also have " ... = rotate1 (rotate1 [i, j , k])"
-            by (metis One_nat_def Suc_1 funpow_0 ijk rotate_Suc rotate_def)
-          also have " ... = [k, i, j]" by simp
-          finally have "map ((cycle_of_list cs) ^^ 2) cs = [k, i, j]" .
-          hence "map (p ^^ 2) [i, j, k] = [k, i, j]" using p ijk by simp
-
-          moreover have "map (cycle_of_list [i, k, j]) [i, j, k] = [k, i, j]"
-            using cs(1) ijk by auto 
-
-          ultimately show ?thesis using \<open>l \<in> {i, j, k}\<close> by auto
-        qed
-      qed
-      hence p2: "p ^^ 2 = (Fun.swap j k id) \<circ> (cycle_of_list [i, j, k]) \<circ> (inv' (Fun.swap j k id))"
-        using conjugation_of_cycle[of "[i, j, k]" "Fun.swap j k id"] cs(1) ijk by auto
+      hence "cycle (d # cs)" and "length (d # cs) = 4" and "card {1..n} = n"
+        using cs(2-3) by auto 
+      hence "set (d # cs) \<noteq> {1..n}"
+        using assms unfolding sym[OF distinct_card[OF \<open>cycle (d # cs)\<close>]]
+        by (metis Suc_n_not_le_n eval_nat_numeral(3)) 
+      then obtain e where e: "e \<notin> set (d # cs)" "e \<in> {1..n}"
+        using d cs(4) by (metis insert_subset list.simps(15) subsetI subset_antisym) 
 
-      have "card ({1..n} - {i, j, k}) \<ge> card {1..n} - card {i, j, k}"
-        by (meson diff_card_le_card_Diff finite.emptyI finite.insertI)
-      hence card_ge_two: "card ({1..n} - {i, j, k}) \<ge> 2"
-        using assms cs ijk by simp
-      then obtain f :: "nat \<Rightarrow> nat" where f: "inj_on f {1..2}" "f ` {1..2} \<subseteq> {1..n} - {i, j, k}"
-        using elts_from_card[OF card_ge_two] by blast  
-      then obtain g h where gh: "g = f 1" "h = f 2" "g \<noteq> h"
-        by (metis Suc_1 atLeastAtMost_iff diff_Suc_1 diff_Suc_Suc inj_onD nat.simps(3) one_le_numeral order_refl)
-      hence g: "g \<in> {1..n} - {i, j, k}" and h: "h \<in> {1..n} - {i, j, k}" using f(2) gh(2) by force+
-      hence gh_simps: "g \<noteq> h \<and> g \<in> {1..n} \<and> h \<in> {1..n} \<and> g \<notin> {i, j, k} \<and> h \<notin> {i, j, k}"
-        using g gh(3) by blast
-      moreover have ijjk: "Fun.swap i j id = Fun.swap j k id \<circ> Fun.swap i j (Fun.swap j k id)"
-               and jkij: "Fun.swap j k id \<circ> (Fun.swap i j id \<circ> Fun.swap j k id) \<circ> inv' (Fun.swap j k id) = Fun.swap g h (Fun.swap g h (Fun.swap i j (Fun.swap j k id)))"
-        by (simp_all add: comp_swap inv_swap_id)
-      moreover have "Fun.swap g h (Fun.swap i j id) = Fun.swap i j (Fun.swap g h id)"
-        by (metis (no_types) comp_id comp_swap gh_simps insert_iff swap_id_independent)
-      moreover have "Fun.swap i j (Fun.swap g h (Fun.swap j k id \<circ> id)) = Fun.swap g h (Fun.swap i j (Fun.swap j k id))"
-        by (metis (no_types) calculation(4) comp_id comp_swap)
-      moreover have "inj (Fun.swap j k id)" "bij (Fun.swap g h id)" "bij (Fun.swap j k id)"
-        by auto
-      moreover have "Fun.swap j k id \<circ> inv' (Fun.swap j k id \<circ> Fun.swap g h id) = Fun.swap g h id"
-        by (metis (no_types) bij_betw_id bij_swap_iff comp_id comp_swap gh_simps insert_iff inv_swap_id o_inv_distrib swap_id_independent swap_nilpotent)
-      moreover have "Fun.swap j k id \<circ> (Fun.swap j k id \<circ> (Fun.swap j k id \<circ> Fun.swap i j (Fun.swap j k id) \<circ> Fun.swap j k id)) \<circ> inv' (Fun.swap j k id) = Fun.swap j k id \<circ> Fun.swap i j (Fun.swap j k id)"
-        by (simp add: comp_swap inv_swap_id)
-      moreover have "Fun.swap j k id \<circ> Fun.swap i j (Fun.swap j k id) \<circ> Fun.swap j k id = Fun.swap j k id \<circ> (Fun.swap j k id \<circ> (Fun.swap j k id \<circ> Fun.swap i j (Fun.swap j k id) \<circ> Fun.swap j k id))"
-        by (simp add: comp_swap inv_swap_id)
-      moreover have "Fun.swap g h id \<circ> (Fun.swap j k id \<circ> Fun.swap i j (Fun.swap j k id) \<circ> Fun.swap j k id) \<circ> inv' (Fun.swap j k id \<circ> Fun.swap g h id) = Fun.swap j k id \<circ> (Fun.swap j k id \<circ> (Fun.swap j k id \<circ> Fun.swap i j (Fun.swap j k id) \<circ> Fun.swap j k id)) \<circ> inv' (Fun.swap j k id)"
-        by (metis calculation(10) calculation(4) calculation(9) comp_assoc comp_id comp_swap swap_nilpotent)
-      ultimately have "Fun.swap i j (Fun.swap j k id) = Fun.swap j k id \<circ> Fun.swap g h id \<circ> (Fun.swap j k id \<circ> Fun.swap i j (Fun.swap j k id) \<circ> Fun.swap j k id) \<circ> inv' (Fun.swap j k id \<circ> Fun.swap g h id)"
-        by (simp add: comp_assoc)
-      then have final_step:
-        "p ^^ 2 = ((Fun.swap j k id) \<circ> (Fun.swap g h id)) \<circ>
-                  (cycle_of_list [i, j, k]) \<circ>
-                  (inv' ((Fun.swap j k id) \<circ> (Fun.swap g h id)))"
-        using ijjk jkij by (auto simp: p2)
+      define q where "q = (Fun.swap d e id) \<circ> (Fun.swap b c id)"
+      hence "bij q"
+        by (simp add: bij_comp)
+      moreover have "q b = c" and "q c = b"
+        using d(1) e(1) unfolding q_def cs_def by simp+
+      moreover have "q a = a"
+        using d(1) e(1) cs(2) unfolding q_def cs_def by auto
+      ultimately have "q \<circ> p \<circ> (inv' q) = cycle_of_list [ a, c, b ]"
+        using conjugation_of_cycle[OF cs(2), of q]
+        unfolding sym[OF cs(1)] unfolding cs_def by simp
+      also have " ... = p \<circ> p"
+        using cs(2) unfolding cs(1) cs_def
+        by (auto, metis comp_id comp_swap swap_commute swap_triple)
+      finally have "q \<circ> p \<circ> (inv' q) = p \<circ> p" .
+      moreover have "bij p"
+        unfolding cs(1) cs_def by (simp add: bij_comp)
+      ultimately have p: "q \<circ> p \<circ> (inv' q) \<circ> (inv' p) = p"
+        by (simp add: bijection.intro bijection.inv_comp_right comp_assoc)
 
-      define q where "q \<equiv> (Fun.swap j k id) \<circ> (Fun.swap g h id)"
-      hence "(p \<circ> p) = q \<circ> p \<circ> (inv' q)"
-        by (metis final_step One_nat_def Suc_1 comp_id funpow.simps(2) funpow_simps_right(1) ijk p)
-      hence "(p \<circ> p) \<circ> (inv' p) = q \<circ> p \<circ> (inv' q) \<circ> (inv' p)" by simp
-      hence 1: "p = q \<circ> p \<circ> (inv' q) \<circ> (inv' p)"
-        using p cycle_permutes[OF cs(1)] o_assoc[of p p "inv' p"]
-        by (simp add: permutation_inverse_works(2))
+      have "swapidseq (Suc (Suc 0)) q"
+        using comp_Suc[OF comp_Suc[OF id], of b c d e] e(1) cs(2)  unfolding q_def cs_def by auto
+      hence "evenperm q"
+        using even_Suc_Suc_iff evenperm_unique by blast
+      moreover have "q permutes { d, e, b, c }"
+        unfolding q_def by (simp add: permutes_compose permutes_swap_id)
+      hence "q permutes {1..n}"
+        using cs(4) d(2) e(2) permutes_subset unfolding cs_def by fastforce
+      ultimately have "q \<in> carrier (alt_group n)"
+        unfolding alt_group_carrier by simp
+      moreover have "p \<in> carrier (alt_group n)"
+        using \<open>p \<in> three_cycles n\<close> three_cycles_incl by blast
+      ultimately have "p \<in> derived_set (alt_group n) (carrier (alt_group n))"
+        using p alt_group_inv_equality unfolding alt_group_mult
+        by (metis (no_types, lifting) UN_iff singletonI)
+      thus "p \<in> derived (alt_group n) (carrier (alt_group n))"
+        unfolding derived_def by (rule incl)
+    qed } note aux_lemma = this
 
-      have "(Fun.swap j k id) \<circ> (Fun.swap g h id) permutes {1..n}"
-        by (metis cs(3) gh_simps ijk insert_subset list.simps(15) permutes_compose permutes_swap_id)
-      moreover have "evenperm ((Fun.swap j k id) \<circ> (Fun.swap g h id))"
-        by (metis cs(1) distinct_length_2_or_more evenperm_comp evenperm_swap gh(3) ijk permutation_swap_id)
-      ultimately have 2: "q \<in> carrier (alt_group n)"
-        by (simp add: alt_group_def q_def)
-
-      have 3: "p \<in> carrier (alt_group n)"
-        using alt_group_as_three_cycles generate.incl[OF \<open>p \<in> three_cycles n\<close>] by simp
+  interpret A: group "alt_group n"
+    using alt_group_is_group .
 
-      from 1 2 3 show "p \<in> derived_set (alt_group n) (carrier (alt_group n))"
-        using alt_group_is_group[of n] alt_group_inv_equality[OF 2] alt_group_inv_equality[OF 3]
-        unfolding alt_group_def sym_group_def by fastforce
-    qed
-    hence "generate (alt_group n) (three_cycles n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
-      unfolding derived_def
-      using group.mono_generate[OF alt_group_is_group[of n]] derived_set_in_carrier by simp
-    thus ?thesis using alt_group_as_three_cycles by blast
-  qed
+  have "generate (alt_group n) (three_cycles n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
+    using A.generate_subgroup_incl[OF _ A.derived_is_subgroup] aux_lemma by (meson subsetI) 
+  thus "carrier (alt_group n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
+    using alt_group_carrier_as_three_cycles by simp
 qed
 
-corollary alt_group_not_solvable:
-  assumes "n \<ge> 5"
-  shows "\<not> solvable (alt_group n)"
+corollary alt_group_is_unsolvable:
+  assumes "n \<ge> 5" shows "\<not> solvable (alt_group n)"
 proof (rule ccontr)
-  assume "\<not> \<not> solvable (alt_group n)" hence "solvable (alt_group n)" by simp
-  then obtain k
-    where trivial_seq: "(derived (alt_group n) ^^ k) (carrier (alt_group n)) = { \<one>\<^bsub>alt_group n\<^esub> }"
-    using group.solvable_iff_trivial_derived_seq[OF alt_group_is_group[of n]] by blast
-
-  have "(derived (alt_group n) ^^ k) (carrier (alt_group n)) = (carrier (alt_group n))"
-    apply (induction k) using derived_alt_group_is_cons[OF assms] by auto
-  hence "carrier (alt_group n) = { \<one>\<^bsub>alt_group n\<^esub> }"
-    using trivial_seq by auto
-  hence singleton: "carrier (alt_group n) = { id }"
-    by (simp add: alt_group_def sym_group_def) 
-
-  have "set [1 :: nat, 2, 3] \<subseteq> {1..n}" using assms by auto
-  moreover have "cycle [1 :: nat, 2, 3]" by simp
-  moreover have "length [1 :: nat, 2, 3] = 3" by simp
-  ultimately have "cycle_of_list [1 :: nat, 2, 3] \<in> three_cycles n"
-    unfolding three_cycles_def by blast
-  hence "cycle_of_list [1 :: nat, 2, 3] \<in> carrier (alt_group n)"
-    using alt_group_as_three_cycles by (simp add: generate.incl)
-
-  moreover have "map (cycle_of_list [1 :: nat, 2, 3]) [1 :: nat, 2, 3] = [2 :: nat, 3, 1]"
-    using cyclic_rotation[OF \<open>cycle [1 :: nat, 2, 3]\<close>, of 1] by simp
-  hence "cycle_of_list [1 :: nat, 2, 3] \<noteq> id"
-    by (metis list.map_id list.sel(1) numeral_One numeral_eq_iff semiring_norm(85))
-
-  ultimately show False using singleton by blast
+  assume "\<not> \<not> solvable (alt_group n)"
+  then obtain m where "(derived (alt_group n) ^^ m) (carrier (alt_group n)) = { id }"
+    using group.solvable_iff_trivial_derived_seq[OF alt_group_is_group] unfolding alt_group_one by blast
+  moreover have "(derived (alt_group n) ^^ m) (carrier (alt_group n)) = carrier (alt_group n)"
+    using derived_alt_group_const[OF assms] by (induct m) (auto)
+  ultimately have card_eq_1: "card (carrier (alt_group n)) = 1"
+    by simp
+  have ge_2: "n \<ge> 2"
+    using assms by simp
+  moreover have "2 = fact n"
+    using alt_group_card_carrier[OF ge_2] unfolding card_eq_1
+    by (metis fact_2 mult.right_neutral of_nat_fact)
+  ultimately have "n = 2"
+      by (metis antisym_conv fact_ge_self)
+  thus False
+    using assms by simp
 qed
 
-corollary sym_group_not_solvable:
-  assumes "n \<ge> 5"
-  shows "\<not> solvable (sym_group n)"
+corollary sym_group_is_unsolvable:
+  assumes "n \<ge> 5" shows "\<not> solvable (sym_group n)"
 proof -
-  have "subgroup (kernel (sym_group n) sign_img sign) (sym_group n)"
-    using group_hom.subgroup_kernel sign_is_hom by blast
-  hence "subgroup (carrier (alt_group n)) (sym_group n)"
-    using alt_group_is_kernel_from_sign[of n] by simp
-  hence "group_hom (alt_group n) (sym_group n) id"
-    using group.canonical_inj_is_hom[OF sym_group_is_group[of n]] by (simp add: alt_group_def)
-  thus ?thesis
-    using group_hom.not_solvable[of "alt_group n" "sym_group n" id]
-          alt_group_not_solvable[OF assms] inj_on_id by blast
+  interpret Id: group_hom "alt_group n" "sym_group n" id
+    using group.canonical_inj_is_hom[OF sym_group_is_group alt_group_is_subgroup] alt_group_def by simp
+  show ?thesis
+    using Id.inj_hom_imp_solvable alt_group_is_unsolvable[OF assms] by auto
 qed
 
-end
+end
\ No newline at end of file
diff -r 12dce58bcd3f -r 1b5178abaf97 src/HOL/Algebra/Weak_Morphisms.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Algebra/Weak_Morphisms.thy	Thu Oct 04 15:25:47 2018 +0100
@@ -0,0 +1,498 @@
+(*  Title:      HOL/Algebra/Weak_Morphisms.thy
+    Author:     Paulo Emílio de Vilhena
+*)
+
+theory Weak_Morphisms
+  imports QuotRing
+
+begin
+
+section \<open>Weak Morphisms\<close>
+
+text \<open>The definition of ring isomorphism, as well as the definition of group isomorphism, doesn't
+      enforce any algebraic constraint to the structure of the schemes involved. This seems
+      unnatural, but it turns out to be very useful: in order to prove that a scheme B satisfy
+      certain algebraic constraints, it's sufficient to prove those for a scheme A and show
+      the existence of an isomorphism between A and B. In this section, we explore this idea
+      in a different way: given a scheme A and a function f, we build a scheme B with an
+      algebraic structure of same strength as A where f is an homomorphism from A to B.\<close>
+
+
+subsection \<open>Definitions\<close>
+
+locale weak_group_morphism = normal H G for f and H and G (structure) +
+  assumes inj_mod_subgroup: "\<lbrakk> a \<in> carrier G; b \<in> carrier G \<rbrakk> \<Longrightarrow> f a = f b \<longleftrightarrow> a \<otimes> (inv b) \<in> H"
+
+locale weak_ring_morphism = ideal I R for f and I and R (structure) +
+  assumes inj_mod_ideal: "\<lbrakk> a \<in> carrier R; b \<in> carrier R \<rbrakk> \<Longrightarrow> f a = f b \<longleftrightarrow> a \<ominus> b \<in> I"
+
+
+definition image_group :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'c) monoid_scheme \<Rightarrow> 'b monoid"
+  where "image_group f G \<equiv>
+           \<lparr> carrier = f ` (carrier G),
+               mult = (\<lambda>a b. f ((inv_into (carrier G) f a) \<otimes>\<^bsub>G\<^esub> (inv_into (carrier G) f b))),
+                one = f \<one>\<^bsub>G\<^esub> \<rparr>"
+
+definition image_ring :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'c) ring_scheme \<Rightarrow> 'b ring"
+  where "image_ring f R \<equiv> monoid.extend (image_group f R)
+           \<lparr> zero = f \<zero>\<^bsub>R\<^esub>,
+              add = (\<lambda>a b. f ((inv_into (carrier R) f a) \<oplus>\<^bsub>R\<^esub> (inv_into (carrier R) f b))) \<rparr>"
+
+
+subsection \<open>Weak Group Morphisms\<close>
+
+lemma image_group_carrier: "carrier (image_group f G) = f ` (carrier G)"
+  unfolding image_group_def by simp
+
+lemma image_group_one: "one (image_group f G) = f \<one>\<^bsub>G\<^esub>"
+  unfolding image_group_def by simp
+
+lemma weak_group_morphismsI:
+  assumes "H \<lhd> G" and "\<And>a b. \<lbrakk> a \<in> carrier G; b \<in> carrier G \<rbrakk> \<Longrightarrow> f a = f b \<longleftrightarrow> a \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> b) \<in> H"
+  shows "weak_group_morphism f H G"
+  using assms unfolding weak_group_morphism_def weak_group_morphism_axioms_def by auto
+
+lemma image_group_truncate:
+  fixes R :: "('a, 'b) monoid_scheme"
+  shows "monoid.truncate (image_group f R) = image_group f (monoid.truncate R)"
+  by (simp add: image_group_def monoid.defs)
+
+lemma image_ring_truncate: "monoid.truncate (image_ring f R) = image_group f R"
+  by (simp add: image_ring_def monoid.defs)
+
+lemma (in ring) weak_add_group_morphism:
+  assumes "weak_ring_morphism f I R" shows "weak_group_morphism f I (add_monoid R)"
+proof -
+  have is_normal: "I \<lhd> (add_monoid R)"
+    using ideal_is_normal[OF  weak_ring_morphism.axioms(1)[OF assms]] .
+  show ?thesis
+    using weak_group_morphism.intro[OF is_normal]
+          weak_ring_morphism.inj_mod_ideal[OF assms]
+    unfolding weak_group_morphism_axioms_def a_minus_def a_inv_def
+    by auto
+qed
+
+lemma (in group) weak_group_morphism_range:
+  assumes "weak_group_morphism f H G" and "a \<in> carrier G" shows "f ` (H #> a) = { f a }"
+proof -
+  interpret H: subgroup H G
+    using weak_group_morphism.axioms(1)[OF assms(1)] unfolding normal_def by simp
+  show ?thesis
+  proof
+    show "{ f a } \<subseteq> f ` (H #> a)"
+      using H.one_closed assms(2) unfolding r_coset_def by force
+  next
+    show "f ` (H #> a) \<subseteq> { f a }"
+    proof
+      fix b assume "b \<in> f ` (H #> a)" then obtain h where "h \<in> H" "h \<in> carrier G" "b = f (h \<otimes> a)"
+        unfolding r_coset_def using H.subset by auto
+      thus "b \<in> { f a }"
+        using weak_group_morphism.inj_mod_subgroup[OF assms(1)] assms(2)
+        by (metis inv_solve_right m_closed singleton_iff)
+    qed
+  qed
+qed
+
+lemma (in group) vimage_eq_rcoset:
+  assumes "weak_group_morphism f H G" and "a \<in> carrier G"
+  shows "{ b \<in> carrier G. f b = f a } = H #> a" and "{ b \<in> carrier G. f b = f a } = a <# H"
+proof -
+  interpret H: normal H G
+    using weak_group_morphism.axioms(1)[OF assms(1)] by simp
+  show "{ b \<in> carrier G. f b = f a } = H #> a"
+  proof
+    show "H #> a \<subseteq> { b \<in> carrier G. f b = f a }"
+      using r_coset_subset_G[OF H.subset assms(2)] weak_group_morphism_range[OF assms] by auto
+  next
+    show "{ b \<in> carrier G. f b = f a } \<subseteq> H #> a"
+    proof
+      fix b assume b: "b \<in> { b \<in> carrier G. f b = f a }" then obtain h where "h \<in> H" "b \<otimes> (inv a) = h"
+        using weak_group_morphism.inj_mod_subgroup[OF assms(1)] assms(2) by fastforce
+      thus "b \<in> H #> a"
+        using H.rcos_module[OF is_group] b assms(2) by blast
+    qed
+  qed
+  thus "{ b \<in> carrier G. f b = f a } = a <# H"
+    by (simp add: assms(2) H.coset_eq)
+qed
+
+lemma (in group) weak_group_morphism_ker:
+  assumes "weak_group_morphism f H G" shows "kernel G (image_group f G) f = H"
+  using vimage_eq_rcoset(1)[OF assms one_closed] weak_group_morphism.axioms(1)[OF assms(1)]
+  by (simp add: image_group_def kernel_def normal_def subgroup.subset)
+
+lemma (in group) weak_group_morphism_inv_into:
+  assumes "weak_group_morphism f H G" and "a \<in> carrier G"
+  obtains h h' where "h  \<in> H" "inv_into (carrier G) f (f a) = h \<otimes> a"
+                 and "h' \<in> H" "inv_into (carrier G) f (f a) = a \<otimes> h'"
+proof -
+  have "inv_into (carrier G) f (f a) \<in> { b \<in> carrier G. f b = f a }"
+    using assms(2) by (auto simp add: inv_into_into f_inv_into_f)
+  thus thesis
+    using that vimage_eq_rcoset[OF assms] unfolding r_coset_def l_coset_def by blast
+qed
+
+proposition (in group) weak_group_morphism_is_iso:
+  assumes "weak_group_morphism f H G" shows "(\<lambda>x. the_elem (f ` x)) \<in> iso (G Mod H) (image_group f G)"
+proof (auto simp add: iso_def hom_def image_group_def)
+  interpret H: normal H G
+    using weak_group_morphism.axioms(1)[OF assms] .
+
+  show "\<And>x. x \<in> carrier (G Mod H) \<Longrightarrow> the_elem (f ` x) \<in> f ` carrier G"
+    unfolding FactGroup_def RCOSETS_def using weak_group_morphism_range[OF assms] by auto
+
+  thus  "bij_betw (\<lambda>x. the_elem (f ` x)) (carrier (G Mod H)) (f ` carrier G)"
+    unfolding bij_betw_def
+  proof (auto)
+    fix a assume "a \<in> carrier G"
+    hence "the_elem (f ` (H #> a)) = f a" and "H #> a \<in> carrier (G Mod H)"
+      using weak_group_morphism_range[OF assms] unfolding FactGroup_def RCOSETS_def by auto
+    thus "f a \<in> (\<lambda>x. the_elem (f ` x)) ` carrier (G Mod H)"
+      using image_iff by fastforce
+  next
+    show "inj_on (\<lambda>x. the_elem (f ` x)) (carrier (G Mod H))"
+    proof (rule inj_onI)
+      fix x y assume "x \<in> (carrier (G Mod H))" and "y \<in> (carrier (G Mod H))"
+      then obtain a b where a: "a \<in> carrier G" "x = H #> a" and b: "b \<in> carrier G" "y = H #> b"
+        unfolding FactGroup_def RCOSETS_def by auto
+      assume "the_elem (f ` x) = the_elem (f ` y)"
+      hence "a \<otimes> (inv b) \<in> H"
+        using weak_group_morphism.inj_mod_subgroup[OF assms]
+              weak_group_morphism_range[OF assms] a b by auto
+      thus "x = y"
+        using a(1) b(1) unfolding a b
+        by (meson H.rcos_const H.subset group.coset_mult_inv1 is_group)
+    qed
+  qed
+
+  fix x y assume "x \<in> carrier (G Mod H)" "y \<in> carrier (G Mod H)"
+  then obtain a b where a: "a \<in> carrier G" "x = H #> a" and b: "b \<in> carrier G" "y = H #> b"
+    unfolding FactGroup_def RCOSETS_def by auto
+
+  show "the_elem (f ` (x <#> y)) = f (inv_into (carrier G) f (the_elem (f ` x)) \<otimes>
+                                      inv_into (carrier G) f (the_elem (f ` y)))"
+  proof (simp add: weak_group_morphism_range[OF assms] a b)
+    obtain h1 h2
+      where h1: "h1 \<in> H" "inv_into (carrier G) f (f a) = a \<otimes> h1"
+        and h2: "h2 \<in> H" "inv_into (carrier G) f (f b) = h2 \<otimes> b"
+      using weak_group_morphism_inv_into[OF assms] a(1) b(1) by metis
+    have "the_elem (f ` ((H #> a) <#> (H #> b))) = the_elem (f ` (H #> (a \<otimes> b)))"
+      by (simp add: a b H.rcos_sum)
+    hence "the_elem (f ` ((H #> a) <#> (H #> b))) = f (a \<otimes> b)"
+      using weak_group_morphism_range[OF assms] a(1) b(1) by auto
+    moreover
+    have "(a \<otimes> h1) \<otimes> (h2 \<otimes> b) = a \<otimes> (h1 \<otimes> h2 \<otimes> b)"
+      by (simp add: a(1) b(1) h1(1) h2(1) H.subset m_assoc)
+    hence "(a \<otimes> h1) \<otimes> (h2 \<otimes> b) \<in> a <# (H #> b)"
+      using h1(1) h2(1) unfolding l_coset_def r_coset_def by auto
+    hence "(a \<otimes> h1) \<otimes> (h2 \<otimes> b) \<in> (a \<otimes> b) <# H"
+      by (simp add: H.subset H.coset_eq a(1) b(1) lcos_m_assoc)
+    hence "f (inv_into (carrier G) f (f a) \<otimes> inv_into (carrier G) f (f b)) = f (a \<otimes> b)"
+      using vimage_eq_rcoset(2)[OF assms] a(1) b(1) unfolding h1 h2 by auto
+    ultimately
+    show "the_elem (f ` ((H #> a) <#> (H #> b))) = f (inv_into (carrier G) f (f a) \<otimes>
+                                                      inv_into (carrier G) f (f b))"
+      by simp
+  qed
+qed
+
+corollary (in group) image_group_is_group:
+  assumes "weak_group_morphism f H G" shows "group (image_group f G)"
+proof -
+  interpret H: normal H G
+    using weak_group_morphism.axioms(1)[OF assms] .
+
+  have "group ((image_group f G) \<lparr> one := the_elem (f ` \<one>\<^bsub>G Mod H\<^esub>) \<rparr>)"
+    using group.iso_imp_img_group[OF H.factorgroup_is_group weak_group_morphism_is_iso[OF assms]] .
+  moreover have "\<one>\<^bsub>G Mod H\<^esub> = H #> \<one>"
+    unfolding FactGroup_def using H.subset by force
+  hence "the_elem (f ` \<one>\<^bsub>G Mod H\<^esub>) = f \<one>"
+    using weak_group_morphism_range[OF assms one_closed] by simp
+  ultimately show ?thesis by (simp add: image_group_def)
+qed
+
+corollary (in group) weak_group_morphism_is_hom:
+  assumes "weak_group_morphism f H G" shows "f \<in> hom G (image_group f G)"
+proof -
+  interpret H: normal H G
+    using weak_group_morphism.axioms(1)[OF assms] .
+
+  have the_elem_hom: "(\<lambda>x. the_elem (f ` x)) \<in> hom (G Mod H) (image_group f G)"
+    using weak_group_morphism_is_iso[OF assms] by (simp add: iso_def)
+  have hom: "(\<lambda>x. the_elem (f ` x)) \<circ> (#>) H \<in> hom G (image_group f G)"
+    using hom_trans[OF H.r_coset_hom_Mod the_elem_hom] by simp
+  have restrict: "\<And>a. a \<in> carrier G \<Longrightarrow> ((\<lambda>x. the_elem (f ` x)) \<circ> (#>) H) a = f a"
+    using weak_group_morphism_range[OF assms] by auto
+  show ?thesis
+    using hom_restrict[OF hom restrict] by simp 
+qed
+
+corollary (in group) weak_group_morphism_group_hom:
+  assumes "weak_group_morphism f H G" shows "group_hom G (image_group f G) f"
+  using image_group_is_group[OF assms] weak_group_morphism_is_hom[OF assms] group_axioms
+  unfolding group_hom_def group_hom_axioms_def by simp
+
+
+subsection \<open>Weak Ring Morphisms\<close>
+
+lemma image_ring_carrier: "carrier (image_ring f R) = f ` (carrier R)"
+  unfolding image_ring_def image_group_def by (simp add: monoid.defs)
+
+lemma image_ring_one: "one (image_ring f R) = f \<one>\<^bsub>R\<^esub>"
+  unfolding image_ring_def image_group_def by (simp add: monoid.defs)
+
+lemma image_ring_zero: "zero (image_ring f R) = f \<zero>\<^bsub>R\<^esub>"
+  unfolding image_ring_def image_group_def by (simp add: monoid.defs)
+
+lemma weak_ring_morphismI:
+  assumes "ideal I R" and "\<And>a b. \<lbrakk> a \<in> carrier R; b \<in> carrier R \<rbrakk> \<Longrightarrow> f a = f b \<longleftrightarrow> a \<ominus>\<^bsub>R\<^esub> b \<in> I"
+  shows "weak_ring_morphism f I R"
+  using assms unfolding weak_ring_morphism_def weak_ring_morphism_axioms_def by auto
+
+lemma (in ring) weak_ring_morphism_range:
+  assumes "weak_ring_morphism f I R" and "a \<in> carrier R" shows "f ` (I +> a) = { f a }"
+  using add.weak_group_morphism_range[OF weak_add_group_morphism[OF assms(1)] assms(2)]
+  unfolding a_r_coset_def .
+
+lemma (in ring) vimage_eq_a_rcoset:
+  assumes "weak_ring_morphism f I R" and "a \<in> carrier R" shows "{ b \<in> carrier R. f b = f a } = I +> a"
+  using add.vimage_eq_rcoset[OF weak_add_group_morphism[OF assms(1)] assms(2)]
+  unfolding a_r_coset_def by simp
+
+lemma (in ring) weak_ring_morphism_ker:
+  assumes "weak_ring_morphism f I R" shows "a_kernel R (image_ring f R) f = I"
+  using add.weak_group_morphism_ker[OF weak_add_group_morphism[OF assms]]
+  unfolding kernel_def a_kernel_def' image_ring_def image_group_def by (simp add: monoid.defs)
+
+lemma (in ring) weak_ring_morphism_inv_into:
+  assumes "weak_ring_morphism f I R" and "a \<in> carrier R"
+  obtains i where "i \<in> I" "inv_into (carrier R) f (f a) = i \<oplus> a"
+  using add.weak_group_morphism_inv_into(1)[OF weak_add_group_morphism[OF assms(1)] assms(2)] by auto
+
+proposition (in ring) weak_ring_morphism_is_iso:
+  assumes "weak_ring_morphism f I R" shows "(\<lambda>x. the_elem (f ` x)) \<in> ring_iso (R Quot I) (image_ring f R)"
+proof (rule ring_iso_memI)
+  show "bij_betw (\<lambda>x. the_elem (f ` x)) (carrier (R Quot I)) (carrier (image_ring f R))"
+   and add_hom: "\<And>x y. \<lbrakk> x \<in> carrier (R Quot I); y \<in> carrier (R Quot I) \<rbrakk> \<Longrightarrow>
+              the_elem (f ` (x \<oplus>\<^bsub>R Quot I\<^esub> y)) = the_elem (f ` x) \<oplus>\<^bsub>image_ring f R\<^esub> the_elem (f ` y)"
+    using add.weak_group_morphism_is_iso[OF weak_add_group_morphism[OF assms]]
+    unfolding iso_def hom_def FactGroup_def FactRing_def A_RCOSETS_def set_add_def
+    by (auto simp add: image_ring_def image_group_def monoid.defs)
+next
+  interpret I: ideal I R
+    using weak_ring_morphism.axioms(1)[OF assms] .
+
+  show "the_elem (f ` \<one>\<^bsub>R Quot I\<^esub>) = \<one>\<^bsub>image_ring f R\<^esub>"
+   and "\<And>x. x \<in> carrier (R Quot I) \<Longrightarrow> the_elem (f ` x) \<in> carrier (image_ring f R)"
+    using weak_ring_morphism_range[OF assms] one_closed I.Icarr
+    by (auto simp add: image_ring_def image_group_def monoid.defs FactRing_def A_RCOSETS_def')
+
+  fix x y assume "x \<in> carrier (R Quot I)" "y \<in> carrier (R Quot I)"
+  then obtain a b where a: "a \<in> carrier R" "x = I +> a" and b: "b \<in> carrier R" "y = I +> b"
+    unfolding FactRing_def A_RCOSETS_def' by auto
+  hence prod: "x \<otimes>\<^bsub>R Quot I\<^esub> y = I +> (a \<otimes> b)"
+    unfolding FactRing_def by (simp add: I.rcoset_mult_add)
+
+  show "the_elem (f ` (x \<otimes>\<^bsub>R Quot I\<^esub> y)) = the_elem (f ` x) \<otimes>\<^bsub>image_ring f R\<^esub> the_elem (f ` y)"
+    unfolding prod
+  proof (simp add: weak_ring_morphism_range[OF assms] a b image_ring_def image_group_def monoid.defs)
+    obtain i j
+      where i: "i \<in> I" "inv_into (carrier R) f (f a) = i \<oplus> a"
+        and j: "j \<in> I" "inv_into (carrier R) f (f b) = j \<oplus> b"
+      using weak_ring_morphism_inv_into[OF assms] a(1) b(1) by metis
+    have "i \<in> carrier R" and "j \<in> carrier R"
+      using I.Icarr i(1) j(1) by auto
+    hence "(i \<oplus> a) \<otimes> (j \<oplus> b) = (i \<oplus> a) \<otimes> j \<oplus> (i \<otimes> b) \<oplus> (a \<otimes> b)"
+      using a(1) b(1) by algebra
+    hence "(i \<oplus> a) \<otimes> (j \<oplus> b) \<in> I +> (a \<otimes> b)"
+      using i(1) j(1) a(1) b(1) unfolding a_r_coset_def' 
+      by (simp add: I.I_l_closed I.I_r_closed)
+    thus "f (a \<otimes> b) = f (inv_into (carrier R) f (f a) \<otimes> inv_into (carrier R) f (f b))"
+      unfolding i j using weak_ring_morphism_range[OF assms m_closed[OF a(1) b(1)]]
+      by (metis imageI singletonD) 
+  qed
+qed
+
+corollary (in ring) image_ring_zero':
+  assumes "weak_ring_morphism f I R" shows "the_elem (f ` \<zero>\<^bsub>R Quot I\<^esub>) = \<zero>\<^bsub>image_ring f R\<^esub>"
+proof -
+  interpret I: ideal I R
+    using weak_ring_morphism.axioms(1)[OF assms] .
+
+  have "\<zero>\<^bsub>R Quot I\<^esub> = I +> \<zero>"
+    unfolding FactRing_def a_r_coset_def' by force
+  thus ?thesis
+    using weak_ring_morphism_range[OF assms zero_closed] unfolding image_ring_zero by simp
+qed
+
+corollary (in ring) image_ring_is_ring:
+  assumes "weak_ring_morphism f I R" shows "ring (image_ring f R)"
+proof -
+  interpret I: ideal I R
+    using weak_ring_morphism.axioms(1)[OF assms] .
+
+  have "ring ((image_ring f R) \<lparr> zero := the_elem (f ` \<zero>\<^bsub>R Quot I\<^esub>) \<rparr>)"
+    using ring.ring_iso_imp_img_ring[OF I.quotient_is_ring weak_ring_morphism_is_iso[OF assms]] by simp
+  thus ?thesis
+    unfolding image_ring_zero'[OF assms] by simp
+qed
+
+corollary (in ring) image_ring_is_field:
+  assumes "weak_ring_morphism f I R" and "field (R Quot I)" shows "field (image_ring f R)"
+  using field.ring_iso_imp_img_field[OF assms(2) weak_ring_morphism_is_iso[OF assms(1)]]
+  unfolding image_ring_zero'[OF assms(1)] by simp
+
+corollary (in ring) weak_ring_morphism_is_hom:
+  assumes "weak_ring_morphism f I R" shows "f \<in> ring_hom R (image_ring f R)"
+proof -
+  interpret I: ideal I R
+    using weak_ring_morphism.axioms(1)[OF assms] .
+
+  have the_elem_hom: "(\<lambda>x. the_elem (f ` x)) \<in> ring_hom (R Quot I) (image_ring f R)"
+    using weak_ring_morphism_is_iso[OF assms] by (simp add: ring_iso_def)
+  have ring_hom: "(\<lambda>x. the_elem (f ` x)) \<circ> (+>) I \<in> ring_hom R (image_ring f R)"
+    using ring_hom_trans[OF I.rcos_ring_hom the_elem_hom] .
+  have restrict: "\<And>a. a \<in> carrier R \<Longrightarrow> ((\<lambda>x. the_elem (f ` x)) \<circ> (+>) I) a = f a"
+    using weak_ring_morphism_range[OF assms] by auto
+  show ?thesis
+    using ring_hom_restrict[OF ring_hom restrict] by simp
+qed
+
+corollary (in ring) weak_ring_morphism_ring_hom:
+  assumes "weak_ring_morphism f I R" shows "ring_hom_ring R (image_ring f R) f"
+  using ring_hom_ringI2[OF ring_axioms image_ring_is_ring[OF assms] weak_ring_morphism_is_hom[OF assms]] .
+
+
+subsection \<open>Injective Functions\<close>
+
+text \<open>If the fuction is injective, we don't need to impose any algebraic restriction to the input
+      scheme in order to state an isomorphism.\<close>
+
+lemma inj_imp_image_group_iso:
+  assumes "inj_on f (carrier G)" shows "f \<in> iso G (image_group f G)"
+  using assms by (auto simp add: image_group_def iso_def bij_betw_def hom_def)
+
+lemma inj_imp_image_group_inv_iso:
+  assumes "inj f" shows "Hilbert_Choice.inv f \<in> iso (image_group f G) G"
+  using assms by (auto simp add: image_group_def iso_def bij_betw_def hom_def inj_on_def)
+
+lemma inj_imp_image_ring_iso:
+  assumes "inj_on f (carrier R)" shows "f \<in> ring_iso R (image_ring f R)"
+  using assms by (auto simp add: image_ring_def image_group_def ring_iso_def
+                                 bij_betw_def ring_hom_def monoid.defs)
+
+lemma inj_imp_image_ring_inv_iso:
+  assumes "inj f" shows "Hilbert_Choice.inv f \<in> ring_iso (image_ring f R) R"
+  using assms by (auto simp add: image_ring_def image_group_def ring_iso_def
+                                 bij_betw_def ring_hom_def inj_on_def monoid.defs)
+
+lemma (in group) inj_imp_image_group_is_group:
+  assumes "inj_on f (carrier G)" shows "group (image_group f G)"
+  using iso_imp_img_group[OF inj_imp_image_group_iso[OF assms]] by (simp add: image_group_def)
+
+lemma (in ring) inj_imp_image_ring_is_ring:
+  assumes "inj_on f (carrier R)" shows "ring (image_ring f R)"
+  using ring_iso_imp_img_ring[OF inj_imp_image_ring_iso[OF assms]]
+  by (simp add: image_ring_def image_group_def monoid.defs)
+
+lemma (in domain) inj_imp_image_ring_is_domain:
+  assumes "inj_on f (carrier R)" shows "domain (image_ring f R)"
+  using ring_iso_imp_img_domain[OF inj_imp_image_ring_iso[OF assms]]
+  by (simp add: image_ring_def image_group_def monoid.defs)
+
+lemma (in field) inj_imp_image_ring_is_field:
+  assumes "inj_on f (carrier R)" shows "field (image_ring f R)"
+  using ring_iso_imp_img_field[OF inj_imp_image_ring_iso[OF assms]]
+  by (simp add: image_ring_def image_group_def monoid.defs)
+
+
+section \<open>Examples\<close>
+
+text \<open>In a lot of different contexts, the lack of dependent types make some definitions quite
+      complicated. The tools developed in this theory give us a way to change the type of a
+      scheme and preserve all of its algebraic properties. We show, in this section, how to
+      make use of this feature in order to solve the problem mentioned above. \<close>
+
+
+subsection \<open>Direct Product\<close>
+
+abbreviation nil_monoid :: "('a list) monoid"
+  where "nil_monoid \<equiv> \<lparr> carrier = { [] }, mult = (\<lambda>a b. []), one = [] \<rparr>"
+
+definition DirProd_list :: "(('a, 'b) monoid_scheme) list \<Rightarrow> ('a list) monoid"
+  where "DirProd_list Gs = foldr (\<lambda>G H. image_group (\<lambda>(x, xs). x # xs) (G \<times>\<times> H)) Gs nil_monoid"
+
+
+subsubsection \<open>Basic Properties\<close>
+
+lemma DirProd_list_carrier:
+  shows "carrier (DirProd_list (G # Gs)) = (\<lambda>(x, xs). x # xs) ` (carrier G \<times> carrier (DirProd_list Gs))"
+  unfolding DirProd_list_def image_group_def by auto
+
+lemma DirProd_list_one:
+  shows "one (DirProd_list Gs) = foldr (\<lambda>G tl. (one G) # tl) Gs []"
+  unfolding DirProd_list_def DirProd_def image_group_def by (induct Gs) (auto)
+
+lemma DirProd_list_carrier_mem:
+  assumes "gs \<in> carrier (DirProd_list Gs)"
+  shows "length gs = length Gs" and "\<And>i. i < length Gs \<Longrightarrow> (gs ! i) \<in> carrier (Gs ! i)"
+proof -
+  let ?same_length = "\<lambda>xs ys. length xs = length ys"
+  let ?in_carrier = "\<lambda>i gs Gs. (gs ! i) \<in> carrier (Gs ! i)"
+  from assms have "?same_length gs Gs \<and> (\<forall>i < length Gs. ?in_carrier i gs Gs)"
+  proof (induct Gs arbitrary: gs, simp add: DirProd_list_def)
+    case (Cons G Gs)
+    then obtain g' gs'
+      where g': "g' \<in> carrier G" and gs': "gs' \<in> carrier (DirProd_list Gs)" and gs: "gs = g' # gs'"
+      unfolding DirProd_list_carrier by auto
+    hence "?same_length gs (G # Gs)" and "\<And>i. i \<in> {(Suc 0)..< length (G # Gs)} \<Longrightarrow> ?in_carrier i gs (G # Gs)"
+      using Cons(1) by auto
+    moreover have "?in_carrier 0 gs (G # Gs)"
+      unfolding gs using g' by simp
+    ultimately show ?case
+      by (metis atLeastLessThan_iff eq_imp_le less_Suc0 linorder_neqE_nat nat_less_le)
+  qed
+  thus "?same_length gs Gs" and "\<And>i. i < length Gs \<Longrightarrow> ?in_carrier i gs Gs"
+    by simp+
+qed
+
+lemma DirProd_list_carrier_memI:
+  assumes "length gs = length Gs" and "\<And>i. i < length Gs \<Longrightarrow> (gs ! i) \<in> carrier (Gs ! i)"
+  shows "gs \<in> carrier (DirProd_list Gs)"
+  using assms
+proof (induct Gs arbitrary: gs, simp add: DirProd_list_def)
+  case (Cons G Gs)
+  then obtain g' gs' where gs: "gs = g' # gs'"
+    by (metis length_Suc_conv)
+  have "g' \<in> carrier G"
+    using Cons(3)[of 0] unfolding gs by auto
+  moreover have "gs' \<in> carrier (DirProd_list Gs)"
+    using Cons unfolding gs by force
+  ultimately show ?case
+    unfolding DirProd_list_carrier gs by blast
+qed
+
+lemma inj_on_DirProd_carrier:
+  shows "inj_on (\<lambda>(g, gs). g # gs) (carrier (G \<times>\<times> (DirProd_list Gs)))"
+  unfolding DirProd_def inj_on_def by auto
+
+lemma DirProd_list_is_group:
+  assumes "\<And>i. i < length Gs \<Longrightarrow> group (Gs ! i)" shows "group (DirProd_list Gs)"
+  using assms
+proof (induct Gs)
+  case Nil thus ?case
+    unfolding DirProd_list_def by (unfold_locales, auto simp add: Units_def)
+next
+  case (Cons G Gs)
+  hence is_group: "group (G \<times>\<times> (DirProd_list Gs))"
+    using DirProd_group[of G "DirProd_list Gs"] by force
+  show ?case
+    using group.inj_imp_image_group_is_group[OF is_group inj_on_DirProd_carrier]
+    unfolding DirProd_list_def by auto 
+qed
+
+lemma DirProd_list_iso:
+  "(\<lambda>(g, gs). g # gs) \<in> iso (G \<times>\<times> (DirProd_list Gs)) (DirProd_list (G # Gs))"
+  using inj_imp_image_group_iso[OF inj_on_DirProd_carrier] unfolding DirProd_list_def by auto
+
+end
\ No newline at end of file