(*  Title:      Composition Series
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory CompositionSeries
imports
  "SimpleGroups"
  "MaximalNormalSubgroups"
begin

section {* Normal series and Composition series *}

subsection {* Preliminaries *}

text {* A subgroup which is unique in cardinality is normal: *}

lemma (in group) unique_sizes_subgrp_normal:
  assumes fin:"finite (carrier G)"
  assumes "\<exists>!Q. Q \<in> subgroups_of_size q"
  shows "(THE Q. Q \<in> subgroups_of_size q) \<lhd> G"
proof -
  from assms obtain Q where "Q \<in> subgroups_of_size q" by auto
  def Q \<equiv> "THE Q. Q \<in> subgroups_of_size q"
  with assms have Qsize:"Q \<in> subgroups_of_size q" using theI by metis
  hence QG:"subgroup Q G" and cardQ:"card Q = q" unfolding subgroups_of_size_def by auto
  from QG have "Q \<lhd> G" apply(rule normalI)
  proof
    fix g
    assume g:"g \<in> carrier G"
    hence invg:"inv g \<in> carrier G" by (metis inv_closed)
    with fin Qsize have "conjugation_action q (inv g) Q \<in> subgroups_of_size q" by (metis conjugation_is_size_invariant)
    with g Qsize have "(inv g) <# (Q #> inv (inv g)) \<in> subgroups_of_size q" unfolding conjugation_action_def by auto
    with invg g have "inv g <# (Q #> g) = Q" by (metis Qsize assms(2) inv_inv)
    with QG QG g show "Q #> g = g <# Q" by (rule conj_wo_inv)
  qed
  with Q_def show ?thesis by simp
qed

text {* A group whose order is the product of two distinct
primes $p$ and $q$ where $p < q$ has a unique subgroup of size $q$: *}

lemma (in group) pq_order_unique_subgrp:
  assumes finite:"finite (carrier G)"
  assumes orderG:"order G = q * p"
  assumes primep:"prime p" and primeq:"prime q" and pq:"p < q"
  shows "\<exists>!Q. Q \<in> (subgroups_of_size q)"
proof -
  from primep primeq pq have nqdvdp:"\<not> (q dvd p)" by (metis less_not_refl3 prime_def)
  def calM \<equiv> "{s. s \<subseteq> carrier G \<and> card s = q ^ 1}"
  def RelM \<equiv> "{(N1, N2). N1 \<in> calM \<and> N2 \<in> calM \<and> (\<exists>g\<in>carrier G. N1 = N2 #> g)}"
  interpret syl: snd_sylow G q 1 p calM RelM
    unfolding snd_sylow_def sylow_def snd_sylow_axioms_def sylow_axioms_def
    using is_group primeq orderG finite nqdvdp calM_def RelM_def by auto
  obtain Q where Q:"Q \<in> subgroups_of_size q" by (metis (lifting, mono_tags) mem_Collect_eq power_one_right subgroups_of_size_def syl.sylow_thm)
  thus ?thesis
  proof (rule ex1I)
     fix P
     assume P:"P \<in> subgroups_of_size q"
     have "card (subgroups_of_size q) mod q = 1" by (metis power_one_right syl.p_sylow_mod_p)
     moreover have "card (subgroups_of_size q) dvd p" by (metis power_one_right syl.num_sylow_dvd_remainder)
     ultimately have "card (subgroups_of_size q) = 1" using pq primep by (metis Divides.mod_less prime_def)
     with Q P show "P = Q" by (auto simp:card_Suc_eq)
  qed
qed

text {* ... And this unique subgroup is normal. *}

corollary (in group) pq_order_subgrp_normal:
  assumes finite:"finite (carrier G)"
  assumes orderG:"order G = q * p"
  assumes primep:"prime p" and primeq:"prime q" and pq:"p < q"
  shows "(THE Q. Q \<in> subgroups_of_size q) \<lhd> G"
using assms by (metis pq_order_unique_subgrp unique_sizes_subgrp_normal)

text {* The trivial subgroup is normal in every group. *}

lemma (in group) trivial_subgroup_is_normal:
  shows "{\<one>} \<lhd> G"
unfolding normal_def normal_axioms_def r_coset_def l_coset_def by (auto intro: normalI subgroupI simp: is_group)

subsection {* Normal Series *}

text {* We define a normal series as a locale which fixes one group
@{term G} and a list @{term \<GG>} of subsets of @{term G}'s carrier. This list
must begin with the trivial subgroup, end with the carrier of the group itself
and each of the list items must be a normal subgroup of its successor. *}

locale normal_series = group +
  fixes \<GG>
  assumes notempty:"\<GG> \<noteq> []"
  assumes hd:"hd \<GG> = {\<one>}"
  assumes last:"last \<GG> = carrier G"
  assumes normal:"\<And>i. i + 1 < length \<GG> \<Longrightarrow> (\<GG> ! i) \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>"

lemma (in normal_series) is_normal_series: "normal_series G \<GG>" by (rule normal_series_axioms)

text {* For every group there is a "trivial" normal series consisting
only of the group itself and its trivial subgroup. *}

lemma (in group) trivial_normal_series:
  shows "normal_series G [{\<one>}, carrier G]"
unfolding normal_series_def normal_series_axioms_def
using is_group trivial_subgroup_is_normal by auto

text {* We can also show that the normal series presented above is the only such with
a length of two: *}

lemma (in normal_series) length_two_unique:
  assumes "length \<GG> = 2"
  shows "\<GG> = [{\<one>}, carrier G]"
proof(rule nth_equalityI)
  from assms show "length \<GG> = length [{\<one>}, carrier G]" by auto
next
  show "\<forall>i<length \<GG>. \<GG> ! i = [{\<one>}, carrier G] ! i"
  proof(rule allI, rule impI)
    fix i
    assume i:"i < length \<GG>"
    with assms have "i = 0 \<or> i = 1" by auto
    thus "\<GG> ! i = [{\<one>}, carrier G] ! i"
    proof(rule disjE)
      assume i:"i = 0"
      hence "\<GG> ! i = hd \<GG>" by (metis hd_conv_nth notempty)
      thus "\<GG> ! i = [{\<one>}, carrier G] ! i" using hd i by simp
    next
      assume i:"i = 1"
      with assms have "\<GG> ! i = last \<GG>" by (metis diff_add_inverse last_conv_nth nat_1_add_1 notempty)
      thus "\<GG> ! i = [{\<one>}, carrier G] ! i" using last i by simp
    qed
  qed
qed

text {* We can construct new normal series by expanding existing ones: If we
append the carrier of a group @{term G} to a normal series for a normal subgroup
@{term "H \<lhd> G"} we receive a normal series for @{term G}. *}

lemma (in group) normal_series_extend:
  assumes normal:"normal_series (G\<lparr>carrier := H\<rparr>) \<HH>"
  assumes HG:"H \<lhd> G"
  shows "normal_series G (\<HH> @ [carrier G])"
proof -
  from normal interpret normalH: normal_series "(G\<lparr>carrier := H\<rparr>)" \<HH>.
  from normalH.hd have "hd \<HH> = {\<one>}" by simp
  with normalH.notempty have hdTriv:"hd (\<HH> @ [carrier G]) = {\<one>}" by (metis hd_append2)
  show ?thesis unfolding normal_series_def normal_series_axioms_def using is_group
  proof auto
    fix x
    assume "x \<in> hd (\<HH> @ [carrier G])"
    with hdTriv show "x = \<one>" by simp
  next
    from hdTriv show  "\<one> \<in> hd (\<HH> @ [carrier G])" by simp
  next
    fix i
    assume i:"i < length \<HH>"
    show "(\<HH> @ [carrier G]) ! i \<lhd> G\<lparr>carrier := (\<HH> @ [carrier G]) ! Suc i\<rparr>"
    proof (cases "i + 1 < length \<HH>")
      case True
      with normalH.normal have "\<HH> ! i \<lhd> G\<lparr>carrier := \<HH> ! (i + 1)\<rparr>" by auto
      with i have "(\<HH> @ [carrier G]) ! i \<lhd> G\<lparr>carrier := \<HH> ! (i + 1)\<rparr>" using nth_append by metis
      with True show "(\<HH> @ [carrier G]) ! i \<lhd> G\<lparr>carrier := (\<HH> @ [carrier G]) ! (Suc i)\<rparr>" using nth_append Suc_eq_plus1 by metis
    next
      case False
      with i have i2:"i + 1 = length \<HH>" by simp
      from i have "(\<HH> @ [carrier G]) ! i = \<HH> ! i" by (metis nth_append)
      also from i2 normalH.notempty have "... = last \<HH>" by (metis add_diff_cancel_right' last_conv_nth)
      also from normalH.last have "... = H" by simp
      finally have "(\<HH> @ [carrier G]) ! i = H".
      moreover from i2 have "(\<HH> @ [carrier G]) ! (i + 1) = carrier G" by (metis nth_append_length)
      ultimately show ?thesis using HG by auto
    qed
  qed
qed

text {* All entries of a normal series for $G$ are subgroups of $G$. *}

lemma (in normal_series) normal_series_subgroups:
  shows "i < length \<GG> \<Longrightarrow> subgroup (\<GG> ! i) G"
proof -
  have "i + 1 < length \<GG> \<Longrightarrow> subgroup (\<GG> ! i) G"
  proof (induction "length \<GG> - (i + 2)" arbitrary: i)
    case 0
    hence i:"i + 2 = length \<GG>" using assms by simp
    hence ii:"i + 1 = length \<GG> - 1" using assms by force
    from i normal have "\<GG> ! i \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>" by auto
    with ii last notempty show "subgroup (\<GG> ! i) G" using last_conv_nth normal_imp_subgroup by fastforce
  next
    case (Suc k)
    from Suc(3)  normal have i:"subgroup (\<GG> ! i) (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>)" using normal_imp_subgroup by auto
    from Suc(2) have k:"k = length \<GG> - ((i + 1) + 2)" by arith
    with Suc have "subgroup (\<GG> ! (i + 1)) G" by simp
    with i show "subgroup (\<GG> ! i) G" by (metis is_group subgroup.subgroup_of_subgroup)
  qed
  moreover have "i + 1 = length \<GG> \<Longrightarrow> subgroup (\<GG> ! i) G"
    using last notempty last_conv_nth by (metis add_diff_cancel_right' subgroup_self)
  ultimately show "i < length \<GG> \<Longrightarrow> subgroup (\<GG> ! i) G" by force
qed

text {* The second to last entry of a normal series is a normal subgroup of G. *}

lemma (in normal_series) normal_series_snd_to_last:
  shows "\<GG> ! (length \<GG> - 2) \<lhd> G"
proof (cases "2 \<le> length \<GG>")
  case False
  with notempty have length:"length \<GG> = 1" by (metis Suc_eq_plus1 leI length_0_conv less_2_cases plus_nat.add_0)
  with hd have "\<GG> ! (length \<GG> - 2) = {\<one>}" using hd_conv_nth notempty by auto
  with length show ?thesis by (metis trivial_subgroup_is_normal)
next
  case True
  hence "(length \<GG> - 2) + 1 < length \<GG>" by arith
  with normal last have "\<GG> ! (length \<GG> - 2) \<lhd> G\<lparr>carrier := \<GG> ! ((length \<GG> - 2) + 1)\<rparr>" by auto
  with True have "\<GG> ! (length \<GG> - 2) \<lhd> G\<lparr>carrier :=  \<GG> ! (length \<GG> - 1)\<rparr>" by (metis Nat.add_diff_assoc comm_monoid_diff_class.add_diff_cancel_left add.commute one_add_one)
  with notempty last show ?thesis using last_conv_nth by force
qed

text {* Just like the expansion of normal series, every prefix of a normal series is again a normal series. *}

lemma (in normal_series) normal_series_prefix_closed:
  assumes "i \<le> length \<GG>" and "0 < i"
  shows "normal_series (G\<lparr>carrier := \<GG> ! (i - 1)\<rparr>) (take i \<GG>)"
unfolding normal_series_def normal_series_axioms_def
using assms
apply (auto del:equalityI)
 apply (metis diff_Suc_Suc diff_is_0_eq' gr_implies_not0 minus_nat.diff_0 normal_series_subgroups not0_implies_Suc not_less_eq subgroup_imp_group zero_less_diff)
proof -
  from assms have "hd (take i \<GG>) = (take i \<GG>) ! 0" by (metis gr_implies_not0 hd_conv_nth notempty take_eq_Nil)
  also from assms have "... = \<GG> ! 0" by (metis nth_take)
  also from hd have "... = {\<one>}" by (metis hd_conv_nth notempty)
  finally show "hd (take i \<GG>) = {\<one>}".
next
  from assms have "last (take i \<GG>) = (take i \<GG>) ! (length (take i \<GG>) - 1)" by (metis last_conv_nth neq0_conv notempty take_eq_Nil)
  also from assms have "... = (take i \<GG>) ! (i - 1)" by (metis length_take min.absorb2)
  also from assms have "... = \<GG> ! (i - 1)" by (metis diff_less nth_take zero_less_one)
  finally show "last (take i \<GG>) = \<GG> ! (i - Suc 0)" by simp
next
  fix j
  assume j:"Suc j < i"
  hence "j + 1 < length \<GG>" using assms by simp
  with normal show "\<GG> ! j \<lhd> G\<lparr>carrier := \<GG> ! (Suc j)\<rparr>" by auto
qed

text {* If a group's order is the product of two distinct primes @{term p} and @{term q}, where
@{term "p < q"}, we can construct a normal series using the only subgroup of size  @{term q}. *}

lemma (in group) pq_order_normal_series:
  assumes finite:"finite (carrier G)"
  assumes orderG:"order G = q * p"
  assumes primep:"prime p" and primeq:"prime q" and pq:"p < q"
  shows "normal_series G [{\<one>}, (THE H. H \<in> subgroups_of_size q), carrier G]"
proof -
  def H \<equiv> "(THE H. H \<in> subgroups_of_size q)"
  with assms have HG:"H \<lhd> G" by (metis pq_order_subgrp_normal)
  then interpret groupH: group "G\<lparr>carrier := H\<rparr>" unfolding normal_def by (metis subgroup_imp_group)
  have "normal_series (G\<lparr>carrier := H\<rparr>) [{\<one>}, H]"  using groupH.trivial_normal_series by auto
  with HG show ?thesis unfolding H_def by (metis append_Cons append_Nil normal_series_extend)
qed

text {* The following defines the list of all quotient groups of the normal series: *}

definition (in normal_series) quotients
  where "quotients = map (\<lambda>i. G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i) [0..<((length \<GG>) - 1)]"

text {* The list of quotient groups has one less entry than the series itself: *}

lemma (in normal_series) quotients_length:
  shows "length quotients + 1 = length \<GG>"
proof -
  have "length quotients + 1 = length [0..<((length \<GG>) - 1)] + 1" unfolding quotients_def by simp
  also have "... = (length \<GG> - 1) + 1" by (metis diff_zero length_upt)
  also with notempty have "... = length \<GG>" by (metis add_eq_if comm_monoid_diff_class.diff_cancel length_0_conv add.commute zero_neq_one)
  finally show ?thesis .
qed

lemma (in normal_series) last_quotient:
  assumes "length \<GG> > 1"
  shows "last quotients = G Mod \<GG> ! (length \<GG> - 1 - 1)"
proof -
  from assms have lsimp:"length \<GG> - 1 - 1 + 1 = length \<GG> - 1" by auto
  from assms have "quotients \<noteq> []" unfolding quotients_def by auto
  hence "last quotients = quotients ! (length quotients - 1)" by (metis last_conv_nth)
  also have "\<dots> = quotients ! (length \<GG> - 1 - 1)" by (metis add_diff_cancel_left' quotients_length add.commute)
  also have "\<dots> = G\<lparr>carrier := \<GG> ! ((length \<GG> - 1 - 1) + 1)\<rparr> Mod \<GG> ! (length \<GG> - 1 - 1)"
    unfolding quotients_def using assms by auto
  also have "\<dots> = G\<lparr>carrier := \<GG> ! (length \<GG> - 1)\<rparr> Mod \<GG> ! (length \<GG> - 1 - 1)" using lsimp by simp
  also have "\<dots> = G Mod \<GG> ! (length \<GG> - 1 - 1)" using last last_conv_nth notempty by force
  finally show ?thesis .
qed

text {* The next lemma transports the constituting properties of a normal series
along an isomorphism of groups. *}

lemma (in normal_series) normal_series_iso:
  assumes H:"group H"
  assumes iso:"\<Psi> \<in> G \<cong> H"
  shows "normal_series H (map (image \<Psi>) \<GG>)"
apply (simp add: normal_series_def normal_series_axioms_def)
using H notempty apply simp
proof (rule conjI)
  from H is_group iso have group_hom:"group_hom G H \<Psi>" unfolding group_hom_def group_hom_axioms_def iso_def by auto
  have "hd (map (image \<Psi>) \<GG>) = \<Psi> ` {\<one>}" by (metis hd_map hd notempty)
  also have "\<dots> = {\<Psi> \<one>}" by (metis image_empty image_insert)
  also have "\<dots> = {\<one>\<^bsub>H\<^esub>}" using group_hom group_hom.hom_one by auto
  finally show "hd (map (op ` \<Psi>) \<GG>) = {\<one>\<^bsub>H\<^esub>}".
next
  show "last (map (op ` \<Psi>) \<GG>) = carrier H \<and> (\<forall>i. Suc i < length \<GG> \<longrightarrow> \<Psi> ` \<GG> ! i \<lhd> H\<lparr>carrier := \<Psi> ` \<GG> ! Suc i\<rparr>)"
  proof (auto del: equalityI)
    have "last (map (op ` \<Psi>) \<GG>) = \<Psi> ` (carrier G)" using last last_map notempty by metis
    also have "\<dots> = carrier H" using iso unfolding iso_def bij_betw_def by simp
    finally show "last (map (op ` \<Psi>) \<GG>) = carrier H".
  next
    fix i
    assume i:"Suc i < length \<GG>"
    hence norm:"\<GG> ! i \<lhd> G\<lparr>carrier := \<GG> ! Suc i\<rparr>" using normal by simp
    moreover have "restrict \<Psi> (\<GG> ! Suc i) \<in> (G\<lparr>carrier := \<GG> ! Suc i\<rparr>) \<cong> H\<lparr>carrier := \<Psi> ` \<GG> ! Suc i\<rparr>"
      by (metis H i is_group iso iso_restrict normal_series_subgroups)
    moreover have "group (G\<lparr>carrier := \<GG> ! Suc i\<rparr>)" by (metis i normal_series_subgroups subgroup_imp_group)
    moreover hence "subgroup (\<GG> ! Suc i) G" by (metis i normal_series_subgroups)
    hence "subgroup (\<Psi> ` \<GG> ! Suc i) H" by (metis H is_group iso iso_subgroup)
    hence "group (H\<lparr>carrier := \<Psi> ` \<GG> ! Suc i\<rparr>)" by (metis H subgroup.subgroup_is_group)
    ultimately have "restrict \<Psi> (\<GG> ! Suc i) ` \<GG> ! i \<lhd> H\<lparr>carrier := \<Psi> ` \<GG> ! Suc i\<rparr>"
      using is_group H iso_normal_subgroup by auto
    moreover from norm have "\<GG> ! i \<subseteq> \<GG> ! Suc i" unfolding normal_def subgroup_def by auto
    hence "{y. \<exists>x\<in>\<GG> ! i. y = (if x \<in> \<GG> ! Suc i then \<Psi> x else undefined)} = {y. \<exists>x\<in>\<GG> ! i. y = \<Psi> x}" by auto
    ultimately show "\<Psi> ` \<GG> ! i \<lhd> H\<lparr>carrier := \<Psi> ` \<GG> ! Suc i\<rparr>" unfolding restrict_def image_def by auto
  qed
qed

subsection {* Composition Series *}

text {* A composition series is a normal series where all consecutive factor groups are simple: *}

locale composition_series = normal_series +
  assumes simplefact:"\<And>i. i + 1 <  length \<GG> \<Longrightarrow> simple_group (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)"

lemma (in composition_series) is_composition_series:
  shows "composition_series G \<GG>"
by (rule composition_series_axioms)

text {* A composition series for a group $G$ has length one if and only if $G$ is the trivial group. *}

lemma (in composition_series) composition_series_length_one:
  shows "(length \<GG> = 1) = (\<GG> = [{\<one>}])"
proof
  assume "length \<GG> = 1"
  with hd have "length \<GG> = length [{\<one>}] \<and> (\<forall>i < length \<GG>. \<GG> ! i = [{\<one>}] ! i)" using hd_conv_nth notempty by force
  thus "\<GG> = [{\<one>}]" using list_eq_iff_nth_eq by blast
next
  assume "\<GG> = [{\<one>}]"
  thus "length \<GG> = 1" by simp
qed

lemma (in composition_series) composition_series_triv_group:
  shows "(carrier G = {\<one>}) = (\<GG> = [{\<one>}])"
proof
  assume G:"carrier G = {\<one>}"
  have "length \<GG> = 1"
  proof (rule ccontr)
    assume "length \<GG> \<noteq> 1"
    with notempty have length:"length \<GG> \<ge> 2" by (metis Suc_eq_plus1 length_0_conv less_2_cases not_less plus_nat.add_0)
    with simplefact hd hd_conv_nth notempty have "simple_group (G\<lparr>carrier := \<GG> ! 1\<rparr> Mod {\<one>})" by force
    moreover have SG:"subgroup (\<GG> ! 1) G" using length normal_series_subgroups by auto
    hence "group (G\<lparr>carrier := \<GG> ! 1\<rparr>)" by (metis subgroup_imp_group)
    ultimately have  "simple_group (G\<lparr>carrier := \<GG> ! 1\<rparr>)" using group.trivial_factor_iso simple_group.iso_simple by fastforce
    moreover from SG G have "carrier (G\<lparr>carrier := \<GG> ! 1\<rparr>) = {\<one>}" unfolding subgroup_def by auto
    ultimately show False using simple_group.simple_not_triv by force
  qed
  thus "\<GG> = [{\<one>}]" by (metis composition_series_length_one)
next
  assume "\<GG> = [{\<one>}]"
  with last show "carrier G = {\<one>}" by auto
qed

text {* The inner elements of a composition series may not consist of the trivial subgroup or the
group itself. *}

lemma (in composition_series) inner_elements_not_triv:
  assumes "i + 1 < length \<GG>"
  assumes "i > 0"
  shows "\<GG> ! i \<noteq> {\<one>}"
proof
  from assms have "(i - 1) + 1 < length \<GG>" by simp
  hence simple:"simple_group (G\<lparr>carrier := \<GG> ! ((i - 1) + 1)\<rparr> Mod \<GG> ! (i - 1))" using simplefact by auto
  assume i:"\<GG> ! i = {\<one>}"
  moreover from assms have "(i - 1) + 1 = i" by auto
  ultimately have "G\<lparr>carrier := \<GG> ! ((i - 1) + 1)\<rparr> Mod \<GG> ! (i - 1) = G\<lparr>carrier := {\<one>}\<rparr> Mod \<GG> ! (i - 1)" using i by auto
  hence "order (G\<lparr>carrier := \<GG> ! ((i - 1) + 1)\<rparr> Mod \<GG> ! (i - 1)) = 1" unfolding FactGroup_def order_def RCOSETS_def by force
  thus "False" using i simple unfolding simple_group_def simple_group_axioms_def by auto
qed

text {* A composition series of a simple group always is its trivial one. *}

lemma (in composition_series) composition_series_simple_group:
  shows "(simple_group G) = (\<GG> = [{\<one>}, carrier G])"
proof
  assume "\<GG> = [{\<one>}, carrier G]"
  with simplefact have "simple_group (G Mod {\<one>})" by auto
  moreover have "the_elem \<in> (G Mod {\<one>}) \<cong> G" by (rule trivial_factor_iso)
  ultimately show "simple_group G" by (metis is_group simple_group.iso_simple)
next
  assume simple:"simple_group G"
  have "length \<GG> > 1"
  proof (rule ccontr)
    assume "\<not> 1 < length \<GG>"
    hence "length \<GG> = 1" by (metis add.commute nat_less_cases not_add_less1 quotients_length)
    hence "carrier G = {\<one>}" using hd last by (metis composition_series_length_one composition_series_triv_group)
    hence "order G = 1" unfolding order_def by auto
    with simple show "False" unfolding simple_group_def simple_group_axioms_def by auto
  qed
  moreover have "length \<GG> \<le> 2"
  proof (rule ccontr)
    def k \<equiv> "length \<GG> - 2"
    assume "\<not> (length \<GG> \<le> 2)"
    hence gt2:"length \<GG> > 2" by simp
    hence ksmall:"k + 1 < length \<GG>" unfolding k_def by auto
    from gt2 have carrier:"\<GG> ! (k + 1) = carrier G" using notempty last last_conv_nth k_def
      by (metis Nat.add_diff_assoc Nat.diff_cancel `\<not> length \<GG> \<le> 2` add.commute nat_le_linear one_add_one)
    from normal ksmall have "\<GG> ! k \<lhd> G\<lparr> carrier := \<GG> ! (k + 1)\<rparr>" by simp
    from simplefact ksmall have simplek:"simple_group (G\<lparr>carrier := \<GG> ! (k + 1)\<rparr> Mod \<GG> ! k)" by simp
    from simplefact ksmall have simplek':"simple_group (G\<lparr>carrier := \<GG> ! ((k - 1) + 1)\<rparr> Mod \<GG> ! (k - 1))" by auto
    have "\<GG> ! k \<lhd> G" using carrier k_def gt2 normal ksmall by force
    with simple have "(\<GG> ! k) = carrier G \<or> (\<GG> ! k) = {\<one>}" unfolding simple_group_def simple_group_axioms_def by simp
    thus "False"
    proof (rule disjE)
      assume "\<GG> ! k = carrier G"
      hence "G\<lparr>carrier := \<GG> ! (k + 1)\<rparr> Mod \<GG> ! k = G Mod (carrier G)" using carrier by auto
      with simplek self_factor_not_simple show "False" by auto
    next
      assume "\<GG> ! k = {\<one>}"
      with ksmall k_def gt2 show "False" using inner_elements_not_triv by auto
    qed
  qed
  ultimately have "length \<GG> = 2" by simp
  thus "\<GG> = [{\<one>}, carrier G]" by (rule length_two_unique)
qed

text {* Two consecutive elements in a composition series are distinct. *}

lemma (in composition_series) entries_distinct:
  assumes finite:"finite (carrier G)"
  assumes i:"i + 1 < length \<GG>"
  shows "\<GG> ! i \<noteq> \<GG> ! (i + 1)"
proof
  from finite have "finite  (\<GG> ! (i + 1))"
    using i normal_series_subgroups subgroup_imp_subset rev_finite_subset by metis
  hence fin:"finite (carrier (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>))" by auto
  from i have norm:"\<GG> ! i \<lhd> (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>)" by (rule normal)
  assume "\<GG> ! i = \<GG> ! (i + 1)"
  hence "\<GG> ! i = carrier (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>)" by auto
  hence "carrier ((G\<lparr>carrier := (\<GG> ! (i + 1))\<rparr>) Mod (\<GG> ! i)) = {\<one>\<^bsub>(G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>) Mod \<GG> ! i\<^esub>}"
    using norm fin normal.fact_group_trivial_iff by metis
  hence "\<not> simple_group ((G\<lparr>carrier := (\<GG> ! (i + 1))\<rparr>) Mod (\<GG> ! i))" by (metis simple_group.simple_not_triv)
  thus False by (metis i simplefact)
qed

text {* The normal series for groups of order @{term "p * q"} is even a composition series: *}

lemma (in group) pq_order_composition_series:
  assumes finite:"finite (carrier G)"
  assumes orderG:"order G = q * p"
  assumes primep:"prime p" and primeq:"prime q" and pq:"p < q"
  shows "composition_series G [{\<one>}, (THE H. H \<in> subgroups_of_size q), carrier G]"
unfolding composition_series_def composition_series_axioms_def
apply(auto)
using assms apply(rule pq_order_normal_series)
proof -
  def H \<equiv> "THE H. H \<in> subgroups_of_size q"
  from assms have exi:"\<exists>!Q. Q \<in> (subgroups_of_size q)" by (auto simp: pq_order_unique_subgrp)
  hence Hsize:"H \<in> subgroups_of_size q" unfolding H_def using theI' by metis
  hence HsubG:"subgroup H G" unfolding subgroups_of_size_def by auto
  then interpret Hgroup: group "G\<lparr>carrier := H\<rparr>" by (metis subgroup_imp_group)
  fix i
  assume "i < Suc (Suc 0)"
  hence "i = 0 \<or> i = 1" by auto
  thus "simple_group (G\<lparr>carrier := [H, carrier G] ! i\<rparr> Mod [{\<one>}, H, carrier G] ! i)"
  proof
    assume i:"i = 0"
    from Hsize have orderH:"order (G\<lparr>carrier := H\<rparr>) = q" unfolding subgroups_of_size_def order_def by simp
    hence "order (G\<lparr>carrier := H\<rparr> Mod {\<one>}) = q" unfolding FactGroup_def using card_rcosets_triv order_def
      by (metis Hgroup.card_rcosets_triv HsubG finite monoid.cases_scheme monoid.select_convs(2) partial_object.select_convs(1) partial_object.update_convs(1) subgroup_finite)
    have "normal {\<one>} (G\<lparr>carrier := H\<rparr>)" by (metis Hgroup.is_group Hgroup.normal_inv_iff HsubG group.trivial_subgroup_is_normal is_group singleton_iff subgroup.one_closed subgroup.subgroup_of_subgroup)
    hence "group (G\<lparr>carrier := H\<rparr> Mod {\<one>})" by (metis normal.factorgroup_is_group)
    with orderH primeq have "simple_group (G\<lparr>carrier := H\<rparr> Mod {\<one>})" by (metis `order (G\<lparr>carrier := H\<rparr> Mod {\<one>}) = q` group.prime_order_simple)
    with i show ?thesis by simp
  next
    assume i:"i = 1"
    from assms exi have "H \<lhd> G" unfolding H_def by (metis pq_order_subgrp_normal)
    hence groupGH:"group (G Mod H)" by (metis normal.factorgroup_is_group)
    from primeq have "q \<noteq> 0" by (metis zero_not_prime_nat)
    from HsubG finite orderG have "card (rcosets H) * card H = q * p" unfolding subgroups_of_size_def using lagrange by simp
    with Hsize have "card (rcosets H) * q = q * p" unfolding subgroups_of_size_def by simp
    with `q \<noteq> 0` have "card (rcosets H) = p" by auto
    hence "order (G Mod H) = p" unfolding order_def FactGroup_def by auto
    with groupGH primep have "simple_group (G Mod H)" by (metis group.prime_order_simple)
    with i show ?thesis by auto
  qed
qed

text {* Prefixes of composition series are also composition series. *}

lemma (in composition_series) composition_series_prefix_closed:
  assumes "i \<le> length \<GG>" and "0 < i"
  shows "composition_series (G\<lparr>carrier := \<GG> ! (i - 1)\<rparr>) (take i \<GG>)"
unfolding composition_series_def composition_series_axioms_def
proof auto
  from assms show "normal_series (G\<lparr>carrier := \<GG> ! (i - Suc 0)\<rparr>) (take i \<GG>)" by (metis One_nat_def normal_series_prefix_closed)
next
  fix j
  assume j:"Suc j < length \<GG>" "Suc j < i"
  with simplefact show "simple_group (G\<lparr>carrier := \<GG> ! Suc j\<rparr> Mod \<GG> ! j)" by (metis Suc_eq_plus1)
qed

text {* The second element in a composition series is simple group. *}

lemma (in composition_series) composition_series_snd_simple:
  assumes "2 \<le> length \<GG>"
  shows "simple_group (G\<lparr>carrier := \<GG> ! 1\<rparr>)"
proof -
  from assms interpret compTake: composition_series "G\<lparr>carrier := \<GG> ! 1\<rparr>" "take 2 \<GG>" by (metis add_diff_cancel_right' composition_series_prefix_closed one_add_one zero_less_numeral)
  from assms have "length (take 2 \<GG>) = 2" by (metis add_diff_cancel_right' append_take_drop_id diff_diff_cancel length_append length_drop)
  hence "(take 2 \<GG>) = [{\<one>\<^bsub>(G\<lparr>carrier := \<GG> ! 1\<rparr>)\<^esub>}, carrier (G\<lparr>carrier := \<GG> ! 1\<rparr>)]" by (rule compTake.length_two_unique)
  thus ?thesis by (metis compTake.composition_series_simple_group)
qed

text {* As a stronger way to state the previous lemma: An entry of a composition series is
  simple if and only if it is the second one. *}

lemma (in composition_series) composition_snd_simple_iff:
  assumes "i < length \<GG>"
  shows "(simple_group (G\<lparr>carrier :=  \<GG> ! i\<rparr>)) = (i = 1)"
proof
  assume simpi:"simple_group (G\<lparr>carrier := \<GG> ! i\<rparr>)"
  hence "\<GG> ! i \<noteq> {\<one>}" using simple_group.simple_not_triv by force
  hence "i \<noteq> 0" using hd hd_conv_nth notempty by auto
  then interpret compTake: composition_series "G\<lparr>carrier := \<GG> ! i\<rparr>" "take (Suc i) \<GG>"
    using assms composition_series_prefix_closed by (metis diff_Suc_1 less_eq_Suc_le zero_less_Suc)
  from simpi have "(take (Suc i) \<GG>) = [{\<one>\<^bsub>G\<lparr>carrier := \<GG> ! i\<rparr>\<^esub>}, carrier (G\<lparr>carrier := \<GG> ! i\<rparr>)]"
    by (metis compTake.composition_series_simple_group)
  hence "length (take (Suc i) \<GG>) = 2" by auto
  hence "min (length \<GG>) (Suc i) = 2" by (metis length_take)
  with assms have "Suc i = 2" by force
  thus "i = 1" by simp
next
  assume i:"i = 1"
  with assms have "2 \<le> length \<GG>" by simp
  with i show "simple_group (G\<lparr>carrier := \<GG> ! i\<rparr>)" by (metis composition_series_snd_simple)
qed

text {* The second to last entry of a normal series is not only a normal subgroup but
  actually even a \emph{maximal} normal subgroup. *}

lemma (in composition_series) snd_to_last_max_normal:
  assumes finite:"finite (carrier G)"
  assumes length:"length \<GG> > 1"
  shows "max_normal_subgroup (\<GG> ! (length \<GG> - 2)) G"
unfolding max_normal_subgroup_def max_normal_subgroup_axioms_def
proof (auto del: equalityI)
  show "\<GG> ! (length \<GG> - 2) \<lhd> G" by (rule normal_series_snd_to_last)
next
  def G' \<equiv> "\<GG> ! (length \<GG> - 2)"
  from length have length21:"length \<GG> - 2 + 1 = length \<GG> - 1" by arith
  from length have "length \<GG> - 2 + 1 < length \<GG>" by arith
  with simplefact have "simple_group (G\<lparr>carrier := \<GG> ! ((length \<GG> - 2) + 1)\<rparr> Mod G')" unfolding G'_def by auto
  with length21 have simple_last:"simple_group (G Mod G')" using last notempty last_conv_nth by fastforce
  {
    assume snd_to_last_eq:"G' = carrier G"
    hence "carrier (G Mod G') = {\<one>\<^bsub>G Mod G'\<^esub>}"
    using normal_series_snd_to_last finite normal.fact_group_trivial_iff unfolding G'_def by metis
    with snd_to_last_eq have "\<not> simple_group (G Mod G')" by (metis self_factor_not_simple)
    with simple_last show False unfolding G'_def by auto
  }
  {
    have G'G:"G' \<lhd> G" unfolding G'_def by (rule normal_series_snd_to_last)
    fix J
    assume J:"J \<lhd> G" "J \<noteq> G'" "J \<noteq> carrier G" "G' \<subseteq> J"
    hence JG'GG':"rcosets\<^bsub>(G\<lparr>carrier := J\<rparr>)\<^esub> G' \<lhd> G Mod G'"  using normality_factorization normal_series_snd_to_last unfolding G'_def by auto
    from G'G J(1,4) have G'J:"G' \<lhd> (G\<lparr>carrier := J\<rparr>)" by (metis normal_imp_subgroup normal_restrict_supergroup)
    from finite J(1) have finJ:"finite J" by (auto simp: normal_imp_subgroup subgroup_finite)
    from JG'GG' simple_last have "rcosets\<^bsub>G\<lparr>carrier := J\<rparr>\<^esub> G' = {\<one>\<^bsub>G Mod G'\<^esub>} \<or> rcosets\<^bsub>G\<lparr>carrier := J\<rparr>\<^esub> G' = carrier (G Mod G')"
      unfolding simple_group_def simple_group_axioms_def by auto
    thus False
    proof
      assume "rcosets\<^bsub>G\<lparr>carrier := J\<rparr>\<^esub> G' = {\<one>\<^bsub>G Mod G'\<^esub>}"
      hence "rcosets\<^bsub>G\<lparr>carrier := J\<rparr>\<^esub> G' = {\<one>\<^bsub>(G\<lparr>carrier := J\<rparr>) Mod G'\<^esub>}" unfolding FactGroup_def by simp
      hence "G' = J" using G'J finJ normal.fact_group_trivial_iff unfolding FactGroup_def by fastforce
      with J(2) show False by simp
    next
      assume facts_eq:"rcosets\<^bsub>G\<lparr>carrier := J\<rparr>\<^esub> G' = carrier (G Mod G')"
      have "J = carrier G"
      proof
        show "J \<subseteq> carrier G" using J(1) normal_imp_subgroup subgroup_imp_subset by force
      next
        show "carrier G \<subseteq> J"
        proof
          fix x
          assume x:"x \<in> carrier G"
          hence "G' #> x \<in> carrier (G Mod G')" unfolding FactGroup_def RCOSETS_def by auto
          hence "G' #> x \<in> rcosets\<^bsub>G\<lparr>carrier := J\<rparr>\<^esub> G'" using facts_eq by auto
          then obtain j where j:"j \<in> J" "G' #> x = G' #> j" unfolding RCOSETS_def r_coset_def by force
          hence "x \<in> G' #> j" using G'G normal_imp_subgroup x repr_independenceD by fastforce
          then obtain g' where g':"g' \<in> G'" "x = g' \<otimes> j" unfolding r_coset_def by auto
          hence "g' \<in> J" using G'J normal_imp_subgroup subgroup_imp_subset by force
          with g'(2) j(1) show  "x \<in> J" using J(1) normal_imp_subgroup subgroup.m_closed by fastforce
        qed
      qed
      with J(3) show False by simp
    qed
  }
qed

text {* For the next lemma we need a few facts about removing adjacent duplicates. *}

lemma remdups_adj_obtain_adjacency:
  assumes "i + 1 < length (remdups_adj xs)" "length xs > 0"
  obtains j where "j + 1 < length xs"
    "(remdups_adj xs) ! i = xs ! j" "(remdups_adj xs) ! (i + 1) = xs ! (j + 1)"
using assms proof (induction xs arbitrary: i thesis)
  case Nil
  hence False by (metis length_greater_0_conv)
  thus thesis..
next
  case (Cons x xs)
  hence "xs \<noteq> []" using Divides.div_less Suc_eq_plus1 Zero_not_Suc div_eq_dividend_iff list.size(3,4) plus_nat.add_0 remdups_adj.simps(2) by metis
  then obtain y xs' where xs:"xs = y # xs'" by (metis list.exhaust)
  from `xs \<noteq> []` have lenxs:"length xs > 0" by simp
  from xs have rem:"remdups_adj (x # xs) = (if x = y then remdups_adj (y # xs') else x # remdups_adj (y # xs'))" using remdups_adj.simps(3) by auto
  show thesis
  proof (cases "x = y")
    case True
    with rem xs have rem2:"remdups_adj (x # xs) = remdups_adj xs" by auto
    with Cons(3) have "i + 1 < length (remdups_adj xs)" by simp
    with Cons.IH lenxs obtain k where j:"k + 1 < length xs" "remdups_adj xs ! i = xs ! k"
        "remdups_adj xs ! (i + 1) = xs ! (k + 1)" by auto
    thus thesis using Cons(2) rem2 by auto
  next
    case False
    with rem xs have rem2:"remdups_adj (x # xs) = x # remdups_adj xs" by auto
    show thesis
    proof (cases i)
      case 0
      have "0 + 1 < length (x # xs)" using lenxs by auto
      moreover have "remdups_adj (x # xs) ! i = (x # xs) ! 0"
      proof -
        have "remdups_adj (x # xs) ! i = (x # remdups_adj (y # xs')) ! 0" using xs rem2 0 by simp
        also have "\<dots> = x" by simp
        also have "\<dots> = (x # xs) ! 0" by simp
        finally show ?thesis.
      qed
      moreover have "remdups_adj (x # xs) ! (i + 1) = (x # xs) ! (0 + 1)"
      proof -
        have "remdups_adj (x # xs) ! (i + 1) = (x # remdups_adj (y # xs')) ! 1" using xs rem2 0 by simp
        also have "\<dots> = remdups_adj (y # xs') ! 0" by simp
        also have "\<dots> = (y # (remdups (y # xs'))) ! 0" by (metis nth_Cons' remdups_adj_Cons_alt)
        also have "\<dots> = y" by simp
        also have "\<dots> = (x # xs) ! (0 + 1)" unfolding xs by simp
        finally show ?thesis.
      qed
      ultimately show thesis by (rule Cons.prems(1))
    next
      case (Suc k)
      with Cons(3) have "k + 1 < length (remdups_adj (x # xs)) - 1" by auto
      also have "\<dots> \<le> length (remdups_adj xs) + 1 - 1" by (metis One_nat_def le_refl list.size(4) rem2)
      also have "\<dots> = length (remdups_adj xs)" by simp
      finally have "k + 1 < length (remdups_adj xs)".
      with Cons.IH lenxs obtain j where j:"j + 1 < length xs" "remdups_adj xs ! k = xs ! j"
        "remdups_adj xs ! (k + 1) = xs ! (j + 1)" by auto
      from j(1) have "Suc j + 1 < length (x # xs)" by simp
      moreover have "remdups_adj (x # xs) ! i = (x # xs) ! (Suc j)"
      proof -
        have "remdups_adj (x # xs) ! i = (x # remdups_adj xs) ! i" using rem2 by simp
        also have "\<dots> = (remdups_adj xs) ! k" using Suc by simp
        also have "\<dots> = xs ! j" using j(2) .
        also have "\<dots> = (x # xs) ! (Suc j)" by simp
        finally show ?thesis .
      qed
      moreover have "remdups_adj (x # xs) ! (i + 1) = (x # xs) ! (Suc j + 1)"
      proof -
        have "remdups_adj (x # xs) ! (i + 1) = (x # remdups_adj xs) ! (i + 1)" using rem2 by simp
        also have "\<dots> = (remdups_adj xs) ! (k + 1)" using Suc by simp
        also have "\<dots> = xs ! (j + 1)" using j(3).
        also have "\<dots> = (x # xs) ! (Suc j + 1)" by simp
        finally show ?thesis.
      qed
      ultimately show thesis by (rule Cons.prems(1))
    qed
  qed
qed

(* This lemma will be there in future versions of List.thy *)
(* This proof is by Manuel Eberl. *)

lemma hd_remdups_adj[simp]: "hd (remdups_adj xs) = hd xs"
  by (induction xs rule: remdups_adj.induct) simp_all

lemma remdups_adj_adjacent:
  "Suc i < length (remdups_adj xs) \<Longrightarrow> remdups_adj xs ! i \<noteq> remdups_adj xs ! Suc i"
proof (induction xs arbitrary: i rule: remdups_adj.induct)
  case (goal3 x y xs i)
  thus ?case by (cases i, cases "x = y") (simp, auto simp: hd_conv_nth[symmetric])
qed simp_all

text {* Intersecting each entry of a composition series with a normal subgroup of $G$ and removing
  all adjacent duplicates yields another composition series. *}

lemma (in composition_series) intersect_normal:
  assumes finite:"finite (carrier G)"
  assumes KG:"K \<lhd> G"
  shows "composition_series (G\<lparr>carrier := K\<rparr>) (remdups_adj (map (\<lambda>H. K \<inter> H) \<GG>))"
unfolding composition_series_def composition_series_axioms_def normal_series_def normal_series_axioms_def
apply (auto simp only: conjI del: equalityI)
proof -
  show "group (G\<lparr>carrier := K\<rparr>)" using KG normal_imp_subgroup subgroup_imp_group by auto
next
  --  {* Show, that removing adjacent duplicates doesn't result in an empty list. *}
  assume "remdups_adj (map (op \<inter> K) \<GG>) = []"
  hence "map (op \<inter> K) \<GG> = []" by (metis remdups_adj_Nil_iff)
  hence "\<GG> = []" by (metis Nil_is_map_conv)
  with notempty show False..
next
  -- {* Show, that the head of the reduced list is still the trivial group *}
  have "\<GG> = {\<one>} # tl \<GG>" using notempty hd by (metis list.sel(1,3) neq_Nil_conv)
  hence "map (op \<inter> K) \<GG> = map (op \<inter> K) ({\<one>} # tl \<GG>)" by simp
  hence "remdups_adj (map (op \<inter> K) \<GG>) = remdups_adj ((K \<inter> {\<one>}) # (map (op \<inter> K) (tl \<GG>)))" by simp
  also have "\<dots> = (K \<inter> {\<one>}) # tl (remdups_adj ((K \<inter> {\<one>}) # (map (op \<inter> K) (tl \<GG>))))" by simp
  finally have "hd (remdups_adj (map (op \<inter> K) \<GG>)) = K \<inter> {\<one>}" using list.sel(1) by metis
  thus "hd (remdups_adj (map (op \<inter> K) \<GG>)) = {\<one>\<^bsub>G\<lparr>carrier := K\<rparr>\<^esub>}"
    using KG normal_imp_subgroup subgroup.one_closed by force
next
  -- {* Show that the last entry is really @{text "K \<inter> G"}. Since we don't have a lemma ready to talk about the
    last entry of a reduced list, we reverse the list twice. *}
  have "rev \<GG> = (carrier G) # tl (rev \<GG>)" by (metis list.sel(1,3) last last_rev neq_Nil_conv notempty rev_is_Nil_conv rev_rev_ident)
  hence "rev (map (op \<inter> K) \<GG>) = map (op \<inter> K) ((carrier G) # tl (rev \<GG>))" by (metis rev_map)
  hence rev:"rev (map (op \<inter> K) \<GG>) = (K \<inter> (carrier G)) # (map (op \<inter> K) (tl (rev \<GG>)))" by simp
  have "last (remdups_adj (map (op \<inter> K) \<GG>)) = hd (rev (remdups_adj (map (op \<inter> K) \<GG>)))"
    by (metis hd_rev map_is_Nil_conv notempty remdups_adj_Nil_iff)
  also have "\<dots> = hd (remdups_adj (rev (map (op \<inter> K) \<GG>)))" by (metis remdups_adj_rev)
  also have "\<dots> = hd (remdups_adj ((K \<inter> (carrier G)) # (map (op \<inter> K) (tl (rev \<GG>)))))" by (metis rev)
  also have "\<dots> = hd ((K \<inter> (carrier G)) # (remdups_adj ((K \<inter> (carrier G)) # (map (op \<inter> K) (tl (rev \<GG>))))))" by (metis list.sel(1) remdups_adj_Cons_alt)
  also have "\<dots> = K" using KG normal_imp_subgroup subgroup_imp_subset by force
  finally show "last (remdups_adj (map (op \<inter> K) \<GG>)) = carrier (G\<lparr>carrier := K\<rparr>)" by auto
next
  -- {* The induction step, using the second isomorphism theorem for groups. *}
  fix j
  assume j:"j + 1 < length (remdups_adj (map (op \<inter> K) \<GG>))"
  have KGnotempty:"(map (op \<inter> K) \<GG>) \<noteq> []" using notempty by (metis Nil_is_map_conv)
  with j obtain i where i:"i + 1 < length (map (op \<inter> K) \<GG>)"
    "(remdups_adj (map (op \<inter> K) \<GG>)) ! j = (map (op \<inter> K) \<GG>) ! i"
    "(remdups_adj (map (op \<inter> K) \<GG>)) ! (j + 1) = (map (op \<inter> K) \<GG>) ! (i + 1)"
    using remdups_adj_obtain_adjacency by force
  from i(1) have i':"i + 1 < length \<GG>" by (metis length_map)
  hence GiSi:"\<GG> ! i \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>" by (metis normal)
  hence GiSi':"\<GG> ! i \<subseteq> \<GG> ! (i + 1)" using normal_imp_subgroup subgroup_imp_subset by force
  from i' have finGSi:"finite (\<GG> ! (i + 1))" using  normal_series_subgroups finite by (metis subgroup_finite)
  from GiSi KG i' normal_series_subgroups have GSiKnormGSi:"\<GG> ! (i + 1) \<inter> K \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>"
    using second_isomorphism_grp.normal_subgrp_intersection_normal
    unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def by auto
  with GiSi have "\<GG> ! i \<inter> (\<GG> ! (i + 1) \<inter> K) \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>"
    by (metis group.normal_subgroup_intersect group.subgroup_imp_group i' is_group is_normal_series normal_series.normal_series_subgroups)
  hence "K \<inter> (\<GG> ! i \<inter> \<GG> ! (i + 1)) \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>" by (metis inf_commute inf_left_commute)
  hence KGinormGSi:"K \<inter> \<GG> ! i \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>" using GiSi' by (metis le_iff_inf)
  moreover have "K \<inter> \<GG> ! i \<subseteq> K \<inter> \<GG> ! (i + 1)" using GiSi' by auto
  moreover have groupGSi:"group (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>)" using i normal_series_subgroups subgroup_imp_group by auto
  moreover have subKGSiGSi:"subgroup (K \<inter> \<GG> ! (i + 1)) (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>)" by (metis GSiKnormGSi inf_sup_aci(1) normal_imp_subgroup)
  ultimately have fstgoal:"K \<inter> \<GG> ! i \<lhd> G\<lparr>carrier := \<GG> ! (i + 1), carrier := K \<inter> \<GG> ! (i + 1)\<rparr>"
    using group.normal_restrict_supergroup by force
  thus "remdups_adj (map (op \<inter> K) \<GG>) ! j \<lhd> G\<lparr>carrier := K, carrier := remdups_adj (map (op \<inter> K) \<GG>) ! (j + 1)\<rparr>"
    using i by auto
  from simplefact have Gisimple:"simple_group (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)" using i' by simp
  hence Gimax:"max_normal_subgroup (\<GG> ! i) (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>)"
    using normal.max_normal_simple_quotient GiSi finGSi by force
  from GSiKnormGSi GiSi have "\<GG> ! i <#>\<^bsub>G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>\<^esub> \<GG> ! (i + 1) \<inter> K \<lhd> (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>)"
    using groupGSi group.normal_subgroup_set_mult_closed by simp
  hence "\<GG> ! i <#> \<GG> ! (i + 1) \<inter> K \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>" unfolding set_mult_def by auto
  hence "\<GG> ! i <#> K \<inter> \<GG> ! (i + 1) \<lhd> G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>" using inf_commute by metis
  moreover have "\<GG> ! i \<subseteq> \<GG> ! i <#>\<^bsub>G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>\<^esub> K \<inter> \<GG> ! (i + 1)"
    using second_isomorphism_grp.H_contained_in_set_mult
    unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def
    using subKGSiGSi GiSi normal_imp_subgroup by fastforce
  hence "\<GG> ! i \<subseteq> \<GG> ! i <#> K \<inter> \<GG> ! (i + 1)" unfolding set_mult_def by auto
  ultimately have KGdisj:"\<GG> ! i <#> K \<inter> \<GG> ! (i + 1) = \<GG> ! i \<or> \<GG> ! i <#> K \<inter> \<GG> ! (i + 1) = \<GG> ! (i + 1)"
    using Gimax unfolding max_normal_subgroup_def max_normal_subgroup_axioms_def
    by auto
  obtain \<phi> where "\<phi> \<in> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (\<GG> ! i \<inter> (K \<inter> \<GG> ! (i + 1))))
    \<cong> (G\<lparr>carrier := \<GG> ! i <#>\<^bsub>G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>\<^esub> K \<inter> \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)"
    using second_isomorphism_grp.normal_intersection_quotient_isom
    unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def
    using GiSi subKGSiGSi normal_imp_subgroup  by fastforce
  hence "\<phi> \<in> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! (i + 1) \<inter> \<GG> ! i))
    \<cong> (G\<lparr>carrier := \<GG> ! i <#>\<^bsub>G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>\<^esub> K \<inter> \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)" by (metis inf_commute)
  hence "\<phi> \<in> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> (\<GG> ! (i + 1) \<inter> \<GG> ! i)))
    \<cong> (G\<lparr>carrier := \<GG> ! i <#>\<^bsub>G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>\<^esub> K \<inter> \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)" by (metis Int_assoc)
  hence "\<phi> \<in> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i))
    \<cong> (G\<lparr>carrier := \<GG> ! i <#>\<^bsub>G\<lparr>carrier := \<GG> ! (i + 1)\<rparr>\<^esub> K \<inter> \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)" by (metis GiSi' Int_absorb2 Int_commute)
  hence \<phi>:"\<phi> \<in> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) \<cong> (G\<lparr>carrier := \<GG> ! i <#> K \<inter> \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)"
    unfolding set_mult_def by auto
  from fstgoal have KGsiKGigroup:"group (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i))" using normal.factorgroup_is_group by auto
  from KGdisj show "simple_group (G\<lparr>carrier := K, carrier := remdups_adj (map (op \<inter> K) \<GG>) ! (j + 1)\<rparr> Mod remdups_adj (map (op \<inter> K) \<GG>) ! j)"
  proof auto
    have groupGi:"group (G\<lparr>carrier := \<GG> ! i\<rparr>)" using i' normal_series_subgroups subgroup_imp_group by auto
    assume "\<GG> ! i <#> K \<inter> \<GG> ! Suc i = \<GG> ! i"
    with \<phi> have "\<phi> \<in> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) \<cong> (G\<lparr>carrier := \<GG> ! i\<rparr> Mod \<GG> ! i)" by auto
    moreover obtain \<psi> where "\<psi> \<in> (G\<lparr>carrier := \<GG> ! i\<rparr> Mod (carrier (G\<lparr>carrier := \<GG> ! i\<rparr>))) \<cong> (G\<lparr>carrier := {\<one>\<^bsub>G\<lparr>carrier := \<GG> ! i\<rparr>\<^esub>}\<rparr>)"
      using group.self_factor_iso groupGi by force
    ultimately obtain \<pi> where "\<pi> \<in> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) \<cong> (G\<lparr>carrier := {\<one>}\<rparr>)"
      using KGsiKGigroup group.iso_trans by fastforce
    hence "order (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) = order (G\<lparr>carrier := {\<one>}\<rparr>)" by (metis iso_order_closed)
    hence "order (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) = 1" unfolding order_def by auto
    hence "carrier (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) = {\<one>\<^bsub>G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)\<^esub>}"
      using group.order_one_triv_iff KGsiKGigroup by auto
    moreover from fstgoal have "K \<inter> \<GG> ! i \<lhd> G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr>" by auto
    moreover from finGSi have "finite (carrier (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr>))" by auto
    ultimately have "K \<inter> \<GG> ! i = carrier (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr>)" by (metis normal.fact_group_trivial_iff)
    hence "(remdups_adj (map (op \<inter> K) \<GG>)) ! j = (remdups_adj (map (op \<inter> K) \<GG>)) ! (j + 1)" using i by auto
    with j have False using remdups_adj_adjacent KGnotempty Suc_eq_plus1 by metis
    thus "simple_group (G\<lparr>carrier := remdups_adj (map (op \<inter> K) \<GG>) ! Suc j\<rparr> Mod remdups_adj (map (op \<inter> K) \<GG>) ! j)"..
  next
    assume "\<GG> ! i <#> K \<inter> \<GG> ! Suc i = \<GG> ! Suc i"
    moreover with \<phi> have "\<phi> \<in> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) \<cong> (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)"by auto
    then obtain \<phi>' where "\<phi>' \<in> (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i) \<cong> (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i))"
      using KGsiKGigroup group.iso_sym by auto
    with Gisimple KGsiKGigroup have "simple_group (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i))" by (metis simple_group.iso_simple)
    with i show "simple_group (G\<lparr>carrier := remdups_adj (map (op \<inter> K) \<GG>) ! Suc j\<rparr> Mod remdups_adj (map (op \<inter> K) \<GG>) ! j)" by auto
  qed
qed

lemma (in group) composition_series_extend:
  assumes "composition_series (G\<lparr>carrier := H\<rparr>) \<HH>"
  assumes "simple_group (G Mod H)" "H \<lhd> G"
  shows "composition_series G (\<HH> @ [carrier G])"
unfolding composition_series_def composition_series_axioms_def
proof auto
  from assms(1) interpret comp\<HH>: composition_series "G\<lparr>carrier := H\<rparr>" \<HH> .
  show "normal_series G (\<HH> @ [carrier G])" using  assms(3) comp\<HH>.is_normal_series by (metis normal_series_extend)
  fix i
  assume i:"i < length \<HH>"
  show "simple_group (G\<lparr>carrier := (\<HH> @ [carrier G]) ! Suc i\<rparr> Mod (\<HH> @ [carrier G]) ! i)"
  proof (cases "i = length \<HH> - 1")
    case True
    hence "(\<HH> @ [carrier G]) ! Suc i = carrier G" by (metis i diff_Suc_1 lessE nth_append_length)
    moreover have "(\<HH> @ [carrier G]) ! i = \<HH> ! i"by (metis butlast_snoc i nth_butlast)
    hence "(\<HH> @ [carrier G]) ! i = H" using True last_conv_nth comp\<HH>.notempty comp\<HH>.last by auto
    ultimately show ?thesis using assms(2) by auto
  next
    case False
    hence "Suc i < length \<HH>" using i by auto
    hence "(\<HH> @ [carrier G]) ! Suc i = \<HH> ! Suc i" using nth_append by metis
    moreover from i have "(\<HH> @ [carrier G]) ! i = \<HH> ! i" using nth_append by metis
    ultimately show ?thesis using `Suc i < length \<HH>` comp\<HH>.simplefact by auto
  qed
qed

lemma (in composition_series) entries_mono:
  assumes "i \<le> j" "j < length \<GG>"
  shows "\<GG> ! i \<subseteq> \<GG> ! j"
using assms proof (induction "j - i" arbitrary: i j)
  case 0
  hence "i = j" by auto
  thus "\<GG> ! i \<subseteq> \<GG> ! j" by auto
next
  case (Suc k i j)
  hence i':"i + (Suc k) = j" "i + 1 < length \<GG>" by auto
  hence ij:"i + 1 \<le> j" by auto
  have "\<GG> ! i \<subseteq> \<GG> ! (i + 1)" using i' normal normal_imp_subgroup subgroup_imp_subset by force
  moreover have "j - (i + 1) = k" "j < length \<GG>" using Suc assms by auto
  hence "\<GG> ! (i + 1) \<subseteq> \<GG> ! j" using Suc(1) ij by auto
  ultimately show "\<GG> ! i \<subseteq> \<GG> ! j" by simp
qed

end


(*  Title:      HOL/Cardinals/Wellorder_Constructions.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Constructions on wellorders.
*)

section \<open>Constructions on Wellorders\<close>

theory Wellorder_Constructions
imports
  Wellorder_Embedding Order_Union
begin

unbundle cardinal_syntax

declare
  ordLeq_Well_order_simp[simp]
  not_ordLeq_iff_ordLess[simp]
  not_ordLess_iff_ordLeq[simp]
  Func_empty[simp]
  Func_is_emp[simp]

lemma Func_emp2[simp]: "A \<noteq> {} \<Longrightarrow> Func A {} = {}" by auto

subsection \<open>Restriction to a set\<close>

lemma Restr_incr2:
"r <= r' \<Longrightarrow> Restr r A <= Restr r' A"
by blast

lemma Restr_incr:
"\<lbrakk>r \<le> r'; A \<le> A'\<rbrakk> \<Longrightarrow> Restr r A \<le> Restr r' A'"
by blast

lemma Restr_Int:
"Restr (Restr r A) B = Restr r (A Int B)"
by blast

lemma Restr_iff: "(a,b) \<in> Restr r A = (a \<in> A \<and> b \<in> A \<and> (a,b) \<in> r)"
by (auto simp add: Field_def)

lemma Restr_subset1: "Restr r A \<le> r"
by auto

lemma Restr_subset2: "Restr r A \<le> A \<times> A"
by auto

lemma wf_Restr:
"wf r \<Longrightarrow> wf(Restr r A)"
using Restr_subset by (elim wf_subset) simp

lemma Restr_incr1:
"A \<le> B \<Longrightarrow> Restr r A \<le> Restr r B"
by blast

subsection \<open>Order filters versus restrictions and embeddings\<close>

lemma ofilter_Restr:
assumes WELL: "Well_order r" and
        OFA: "ofilter r A" and OFB: "ofilter r B" and SUB: "A \<le> B"
shows "ofilter (Restr r B) A"
proof-
  let ?rB = "Restr r B"
  have Well: "wo_rel r" unfolding wo_rel_def using WELL .
  hence Refl: "Refl r" by (auto simp add: wo_rel.REFL)
  hence Field: "Field ?rB = Field r Int B"
  using Refl_Field_Restr by blast
  have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
  by (auto simp add: Well_order_Restr wo_rel_def)
  (* Main proof *)
  show ?thesis
  proof(auto simp add: WellB wo_rel.ofilter_def)
    fix a assume "a \<in> A"
    hence "a \<in> Field r \<and> a \<in> B" using assms Well
    by (auto simp add: wo_rel.ofilter_def)
    with Field show "a \<in> Field(Restr r B)" by auto
  next
    fix a b assume *: "a \<in> A"  and "b \<in> under (Restr r B) a"
    hence "b \<in> under r a"
    using WELL OFB SUB ofilter_Restr_under[of r B a] by auto
    thus "b \<in> A" using * Well OFA by(auto simp add: wo_rel.ofilter_def)
  qed
qed

lemma ofilter_subset_iso:
assumes WELL: "Well_order r" and
        OFA: "ofilter r A" and OFB: "ofilter r B"
shows "(A = B) = iso (Restr r A) (Restr r B) id"
using assms
by (auto simp add: ofilter_subset_embedS_iso)

subsection \<open>Ordering the well-orders by existence of embeddings\<close>

corollary ordLeq_refl_on: "refl_on {r. Well_order r} ordLeq"
using ordLeq_reflexive unfolding ordLeq_def refl_on_def
by blast

corollary ordLeq_trans: "trans ordLeq"
using trans_def[of ordLeq] ordLeq_transitive by blast

corollary ordLeq_preorder_on: "preorder_on {r. Well_order r} ordLeq"
by(auto simp add: preorder_on_def ordLeq_refl_on ordLeq_trans)

corollary ordIso_refl_on: "refl_on {r. Well_order r} ordIso"
using ordIso_reflexive unfolding refl_on_def ordIso_def
by blast

corollary ordIso_trans: "trans ordIso"
using trans_def[of ordIso] ordIso_transitive by blast

corollary ordIso_sym: "sym ordIso"
by (auto simp add: sym_def ordIso_symmetric)

corollary ordIso_equiv: "equiv {r. Well_order r} ordIso"
by (auto simp add:  equiv_def ordIso_sym ordIso_refl_on ordIso_trans)

lemma ordLess_Well_order_simp[simp]:
assumes "r <o r'"
shows "Well_order r \<and> Well_order r'"
using assms unfolding ordLess_def by simp

lemma ordIso_Well_order_simp[simp]:
assumes "r =o r'"
shows "Well_order r \<and> Well_order r'"
using assms unfolding ordIso_def by simp

lemma ordLess_irrefl: "irrefl ordLess"
by(unfold irrefl_def, auto simp add: ordLess_irreflexive)

lemma ordLess_or_ordIso:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "r <o r' \<or> r' <o r \<or> r =o r'"
unfolding ordLess_def ordIso_def
using assms embedS_or_iso[of r r'] by auto

corollary ordLeq_ordLess_Un_ordIso:
"ordLeq = ordLess \<union> ordIso"
by (auto simp add: ordLeq_iff_ordLess_or_ordIso)

lemma not_ordLeq_ordLess:
"r \<le>o r' \<Longrightarrow> \<not> r' <o r"
using not_ordLess_ordLeq by blast

lemma ordIso_or_ordLess:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "r =o r' \<or> r <o r' \<or> r' <o r"
using assms ordLess_or_ordLeq ordLeq_iff_ordLess_or_ordIso by blast

lemmas ord_trans = ordIso_transitive ordLeq_transitive ordLess_transitive
                   ordIso_ordLeq_trans ordLeq_ordIso_trans
                   ordIso_ordLess_trans ordLess_ordIso_trans
                   ordLess_ordLeq_trans ordLeq_ordLess_trans

lemma ofilter_ordLeq:
assumes "Well_order r" and "ofilter r A"
shows "Restr r A \<le>o r"
proof-
  have "A \<le> Field r" using assms by (auto simp add: wo_rel_def wo_rel.ofilter_def)
  thus ?thesis using assms
  by (simp add: ofilter_subset_ordLeq wo_rel.Field_ofilter
      wo_rel_def Restr_Field)
qed

corollary under_Restr_ordLeq:
"Well_order r \<Longrightarrow> Restr r (under r a) \<le>o r"
by (auto simp add: ofilter_ordLeq wo_rel.under_ofilter wo_rel_def)

subsection \<open>Copy via direct images\<close>

lemma Id_dir_image: "dir_image Id f \<le> Id"
unfolding dir_image_def by auto

lemma Un_dir_image:
"dir_image (r1 \<union> r2) f = (dir_image r1 f) \<union> (dir_image r2 f)"
unfolding dir_image_def by auto

lemma Int_dir_image:
assumes "inj_on f (Field r1 \<union> Field r2)"
shows "dir_image (r1 Int r2) f = (dir_image r1 f) Int (dir_image r2 f)"
proof
  show "dir_image (r1 Int r2) f \<le> (dir_image r1 f) Int (dir_image r2 f)"
  using assms unfolding dir_image_def inj_on_def by auto
next
  show "(dir_image r1 f) Int (dir_image r2 f) \<le> dir_image (r1 Int r2) f"
  proof(clarify)
    fix a' b'
    assume "(a',b') \<in> dir_image r1 f" "(a',b') \<in> dir_image r2 f"
    then obtain a1 b1 a2 b2
    where 1: "a' = f a1 \<and> b' = f b1 \<and> a' = f a2 \<and> b' = f b2" and
          2: "(a1,b1) \<in> r1 \<and> (a2,b2) \<in> r2" and
          3: "{a1,b1} \<le> Field r1 \<and> {a2,b2} \<le> Field r2"
    unfolding dir_image_def Field_def by blast
    hence "a1 = a2 \<and> b1 = b2" using assms unfolding inj_on_def by auto
    hence "a' = f a1 \<and> b' = f b1 \<and> (a1,b1) \<in> r1 Int r2 \<and> (a2,b2) \<in> r1 Int r2"
    using 1 2 by auto
    thus "(a',b') \<in> dir_image (r1 \<inter> r2) f"
    unfolding dir_image_def by blast
  qed
qed

(* More facts on ordinal sum: *)

lemma Osum_embed:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "embed r (r Osum r') id"
proof-
  have 1: "Well_order (r Osum r')"
  using assms by (auto simp add: Osum_Well_order)
  moreover
  have "compat r (r Osum r') id"
  unfolding compat_def Osum_def by auto
  moreover
  have "inj_on id (Field r)" by simp
  moreover
  have "ofilter (r Osum r') (Field r)"
  using 1 proof(auto simp add: wo_rel_def wo_rel.ofilter_def
                               Field_Osum under_def)
    fix a b assume 2: "a \<in> Field r" and 3: "(b,a) \<in> r Osum r'"
    moreover
    {assume "(b,a) \<in> r'"
     hence "a \<in> Field r'" using Field_def[of r'] by blast
     hence False using 2 FLD by blast
    }
    moreover
    {assume "a \<in> Field r'"
     hence False using 2 FLD by blast
    }
    ultimately
    show "b \<in> Field r" by (auto simp add: Osum_def Field_def)
  qed
  ultimately show ?thesis
  using assms by (auto simp add: embed_iff_compat_inj_on_ofilter)
qed

corollary Osum_ordLeq:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "r \<le>o r Osum r'"
using assms Osum_embed Osum_Well_order
unfolding ordLeq_def by blast

lemma Well_order_embed_copy:
assumes WELL: "well_order_on A r" and
        INJ: "inj_on f A" and SUB: "f ` A \<le> B"
shows "\<exists>r'. well_order_on B r' \<and> r \<le>o r'"
proof-
  have "bij_betw f A (f ` A)"
  using INJ inj_on_imp_bij_betw by blast
  then obtain r'' where "well_order_on (f ` A) r''" and 1: "r =o r''"
  using WELL  Well_order_iso_copy by blast
  hence 2: "Well_order r'' \<and> Field r'' = (f ` A)"
  using well_order_on_Well_order by blast
  (*  *)
  let ?C = "B - (f ` A)"
  obtain r''' where "well_order_on ?C r'''"
  using well_order_on by blast
  hence 3: "Well_order r''' \<and> Field r''' = ?C"
  using well_order_on_Well_order by blast
  (*  *)
  let ?r' = "r'' Osum r'''"
  have "Field r'' Int Field r''' = {}"
  using 2 3 by auto
  hence "r'' \<le>o ?r'" using Osum_ordLeq[of r'' r'''] 2 3 by blast
  hence 4: "r \<le>o ?r'" using 1 ordIso_ordLeq_trans by blast
  (*  *)
  hence "Well_order ?r'" unfolding ordLeq_def by auto
  moreover
  have "Field ?r' = B" using 2 3 SUB by (auto simp add: Field_Osum)
  ultimately show ?thesis using 4 by blast
qed

subsection \<open>The maxim among a finite set of ordinals\<close>

text \<open>The correct phrasing would be ``a maxim of ...", as \<open>\<le>o\<close> is only a preorder.\<close>

definition isOmax :: "'a rel set \<Rightarrow> 'a rel \<Rightarrow> bool"
where
"isOmax  R r \<equiv> r \<in> R \<and> (\<forall>r' \<in> R. r' \<le>o r)"

definition omax :: "'a rel set \<Rightarrow> 'a rel"
where
"omax R == SOME r. isOmax R r"

lemma exists_isOmax:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "\<exists> r. isOmax R r"
proof-
  have "finite R \<Longrightarrow> R \<noteq> {} \<longrightarrow> (\<forall> r \<in> R. Well_order r) \<longrightarrow> (\<exists> r. isOmax R r)"
  apply(erule finite_induct) apply(simp add: isOmax_def)
  proof(clarsimp)
    fix r :: "('a \<times> 'a) set" and R assume *: "finite R" and **: "r \<notin> R"
    and ***: "Well_order r" and ****: "\<forall>r\<in>R. Well_order r"
    and IH: "R \<noteq> {} \<longrightarrow> (\<exists>p. isOmax R p)"
    let ?R' = "insert r R"
    show "\<exists>p'. (isOmax ?R' p')"
    proof(cases "R = {}")
      assume Case1: "R = {}"
      thus ?thesis unfolding isOmax_def using ***
      by (simp add: ordLeq_reflexive)
    next
      assume Case2: "R \<noteq> {}"
      then obtain p where p: "isOmax R p" using IH by auto
      hence 1: "Well_order p" using **** unfolding isOmax_def by simp
      {assume Case21: "r \<le>o p"
       hence "isOmax ?R' p" using p unfolding isOmax_def by simp
       hence ?thesis by auto
      }
      moreover
      {assume Case22: "p \<le>o r"
       {fix r' assume "r' \<in> ?R'"
        moreover
        {assume "r' \<in> R"
         hence "r' \<le>o p" using p unfolding isOmax_def by simp
         hence "r' \<le>o r" using Case22 by(rule ordLeq_transitive)
        }
        moreover have "r \<le>o r" using *** by(rule ordLeq_reflexive)
        ultimately have "r' \<le>o r" by auto
       }
       hence "isOmax ?R' r" unfolding isOmax_def by simp
       hence ?thesis by auto
      }
      moreover have "r \<le>o p \<or> p \<le>o r"
      using 1 *** ordLeq_total by auto
      ultimately show ?thesis by blast
    qed
  qed
  thus ?thesis using assms by auto
qed

lemma omax_isOmax:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "isOmax R (omax R)"
unfolding omax_def using assms
by(simp add: exists_isOmax someI_ex)

lemma omax_in:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "omax R \<in> R"
using assms omax_isOmax unfolding isOmax_def by blast

lemma Well_order_omax:
assumes "finite R" and "R \<noteq> {}" and "\<forall>r\<in>R. Well_order r"
shows "Well_order (omax R)"
using assms apply - apply(drule omax_in) by auto

lemma omax_maxim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r" and "r \<in> R"
shows "r \<le>o omax R"
using assms omax_isOmax unfolding isOmax_def by blast

lemma omax_ordLeq:
assumes "finite R" and "R \<noteq> {}" and *: "\<forall> r \<in> R. r \<le>o p"
shows "omax R \<le>o p"
proof-
  have "\<forall> r \<in> R. Well_order r" using * unfolding ordLeq_def by simp
  thus ?thesis using assms omax_in by auto
qed

lemma omax_ordLess:
assumes "finite R" and "R \<noteq> {}" and *: "\<forall> r \<in> R. r <o p"
shows "omax R <o p"
proof-
  have "\<forall> r \<in> R. Well_order r" using * unfolding ordLess_def by simp
  thus ?thesis using assms omax_in by auto
qed

lemma omax_ordLeq_elim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "omax R \<le>o p" and "r \<in> R"
shows "r \<le>o p"
using assms omax_maxim[of R r] apply simp
using ordLeq_transitive by blast

lemma omax_ordLess_elim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "omax R <o p" and "r \<in> R"
shows "r <o p"
using assms omax_maxim[of R r] apply simp
using ordLeq_ordLess_trans by blast

lemma ordLeq_omax:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "r \<in> R" and "p \<le>o r"
shows "p \<le>o omax R"
using assms omax_maxim[of R r] apply simp
using ordLeq_transitive by blast

lemma ordLess_omax:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "r \<in> R" and "p <o r"
shows "p <o omax R"
using assms omax_maxim[of R r] apply simp
using ordLess_ordLeq_trans by blast

lemma omax_ordLeq_mono:
assumes P: "finite P" and R: "finite R"
and NE_P: "P \<noteq> {}" and Well_R: "\<forall> r \<in> R. Well_order r"
and LEQ: "\<forall> p \<in> P. \<exists> r \<in> R. p \<le>o r"
shows "omax P \<le>o omax R"
proof-
  let ?mp = "omax P"  let ?mr = "omax R"
  {fix p assume "p \<in> P"
   then obtain r where r: "r \<in> R" and "p \<le>o r"
   using LEQ by blast
   moreover have "r <=o ?mr"
   using r R Well_R omax_maxim by blast
   ultimately have "p <=o ?mr"
   using ordLeq_transitive by blast
  }
  thus "?mp <=o ?mr"
  using NE_P P using omax_ordLeq by blast
qed

lemma omax_ordLess_mono:
assumes P: "finite P" and R: "finite R"
and NE_P: "P \<noteq> {}" and Well_R: "\<forall> r \<in> R. Well_order r"
and LEQ: "\<forall> p \<in> P. \<exists> r \<in> R. p <o r"
shows "omax P <o omax R"
proof-
  let ?mp = "omax P"  let ?mr = "omax R"
  {fix p assume "p \<in> P"
   then obtain r where r: "r \<in> R" and "p <o r"
   using LEQ by blast
   moreover have "r <=o ?mr"
   using r R Well_R omax_maxim by blast
   ultimately have "p <o ?mr"
   using ordLess_ordLeq_trans by blast
  }
  thus "?mp <o ?mr"
  using NE_P P omax_ordLess by blast
qed

subsection \<open>Limit and succesor ordinals\<close>

lemma embed_underS2:
assumes r: "Well_order r" and g: "embed r s g" and a: "a \<in> Field r"
shows "g ` underS r a = underS s (g a)"
  by (meson a bij_betw_def embed_underS g r)

lemma bij_betw_insert:
assumes "b \<notin> A" and "f b \<notin> A'" and "bij_betw f A A'"
shows "bij_betw f (insert b A) (insert (f b) A')"
using notIn_Un_bij_betw[OF assms] by auto

context wo_rel
begin

lemma underS_induct:
  assumes "\<And>a. (\<And> a1. a1 \<in> underS a \<Longrightarrow> P a1) \<Longrightarrow> P a"
  shows "P a"
  by (induct rule: well_order_induct) (rule assms, simp add: underS_def)

lemma suc_underS:
assumes B: "B \<subseteq> Field r" and A: "AboveS B \<noteq> {}" and b: "b \<in> B"
shows "b \<in> underS (suc B)"
using suc_AboveS[OF B A] b unfolding underS_def AboveS_def by auto

lemma underS_supr:
assumes bA: "b \<in> underS (supr A)" and A: "A \<subseteq> Field r"
shows "\<exists> a \<in> A. b \<in> underS a"
proof(rule ccontr, auto)
  have bb: "b \<in> Field r" using bA unfolding underS_def Field_def by auto
  assume "\<forall>a\<in>A.  b \<notin> underS a"
  hence 0: "\<forall>a \<in> A. (a,b) \<in> r" using A bA unfolding underS_def
  by simp (metis REFL in_mono max2_def max2_greater refl_on_domain)
  have "(supr A, b) \<in> r" apply(rule supr_least[OF A bb]) using 0 by auto
  thus False using bA unfolding underS_def by simp (metis ANTISYM antisymD)
qed

lemma underS_suc:
assumes bA: "b \<in> underS (suc A)" and A: "A \<subseteq> Field r"
shows "\<exists> a \<in> A. b \<in> under a"
proof(rule ccontr, auto)
  have bb: "b \<in> Field r" using bA unfolding underS_def Field_def by auto
  assume "\<forall>a\<in>A.  b \<notin> under a"
  hence 0: "\<forall>a \<in> A. a \<in> underS b" using A bA unfolding underS_def
  by simp (metis (lifting) bb max2_def max2_greater mem_Collect_eq under_def rev_subsetD)
  have "(suc A, b) \<in> r" apply(rule suc_least[OF A bb]) using 0 unfolding underS_def by auto
  thus False using bA unfolding underS_def by simp (metis ANTISYM antisymD)
qed

lemma (in wo_rel) in_underS_supr:
assumes j: "j \<in> underS i" and i: "i \<in> A" and A: "A \<subseteq> Field r" and AA: "Above A \<noteq> {}"
shows "j \<in> underS (supr A)"
proof-
  have "(i,supr A) \<in> r" using supr_greater[OF A AA i] .
  thus ?thesis using j unfolding underS_def
  by simp (metis REFL TRANS max2_def max2_equals1 refl_on_domain transD)
qed

lemma inj_on_Field:
assumes A: "A \<subseteq> Field r" and f: "\<And> a b. \<lbrakk>a \<in> A; b \<in> A; a \<in> underS b\<rbrakk> \<Longrightarrow> f a \<noteq> f b"
shows "inj_on f A"
unfolding inj_on_def proof safe
  fix a b assume a: "a \<in> A" and b: "b \<in> A" and fab: "f a = f b"
  {assume "a \<in> underS b"
   hence False using f[OF a b] fab by auto
  }
  moreover
  {assume "b \<in> underS a"
   hence False using f[OF b a] fab by auto
  }
  ultimately show "a = b" using TOTALS A a b unfolding underS_def by auto
qed

lemma ofilter_init_seg_of:
assumes "ofilter F"
shows "Restr r F initial_segment_of r"
using assms unfolding ofilter_def init_seg_of_def under_def by auto

lemma underS_init_seg_of_Collect:
assumes "\<And>j1 j2. \<lbrakk>j2 \<in> underS i; (j1, j2) \<in> r\<rbrakk> \<Longrightarrow> R j1 initial_segment_of R j2"
shows "{R j |j. j \<in> underS i} \<in> Chains init_seg_of"
unfolding Chains_def proof safe
  fix j ja assume jS: "j \<in> underS i" and jaS: "ja \<in> underS i"
  and init: "(R ja, R j) \<notin> init_seg_of"
  hence jja: "{j,ja} \<subseteq> Field r" and j: "j \<in> Field r" and ja: "ja \<in> Field r"
  and jjai: "(j,i) \<in> r" "(ja,i) \<in> r"
  and i: "i \<notin> {j,ja}" unfolding Field_def underS_def by auto
  have jj: "(j,j) \<in> r" and jaja: "(ja,ja) \<in> r" using j ja by (metis in_notinI)+
  show "R j initial_segment_of R ja"
  using jja init jjai i
  by (elim cases_Total3 disjE) (auto elim: cases_Total3 intro!: assms simp: underS_def)
qed

lemma (in wo_rel) Field_init_seg_of_Collect:
assumes "\<And>j1 j2. \<lbrakk>j2 \<in> Field r; (j1, j2) \<in> r\<rbrakk> \<Longrightarrow> R j1 initial_segment_of R j2"
shows "{R j |j. j \<in> Field r} \<in> Chains init_seg_of"
unfolding Chains_def proof safe
  fix j ja assume jS: "j \<in> Field r" and jaS: "ja \<in> Field r"
  and init: "(R ja, R j) \<notin> init_seg_of"
  hence jja: "{j,ja} \<subseteq> Field r" and j: "j \<in> Field r" and ja: "ja \<in> Field r"
  unfolding Field_def underS_def by auto
  have jj: "(j,j) \<in> r" and jaja: "(ja,ja) \<in> r" using j ja by (metis in_notinI)+
  show "R j initial_segment_of R ja"
  using jja init
  by (elim cases_Total3 disjE) (auto elim: cases_Total3 intro!: assms simp: Field_def)
qed

subsubsection \<open>Successor and limit elements of an ordinal\<close>

definition "succ i \<equiv> suc {i}"

definition "isSucc i \<equiv> \<exists> j. aboveS j \<noteq> {} \<and> i = succ j"

definition "zero = minim (Field r)"

definition "isLim i \<equiv> \<not> isSucc i"

lemma zero_smallest[simp]:
assumes "j \<in> Field r" shows "(zero, j) \<in> r"
unfolding zero_def
by (metis AboveS_Field assms subset_AboveS_UnderS subset_antisym subset_refl suc_def suc_least_AboveS)

lemma zero_in_Field: assumes "Field r \<noteq> {}"  shows "zero \<in> Field r"
using assms unfolding zero_def by (metis Field_ofilter minim_in ofilter_def)

lemma leq_zero_imp[simp]:
"(x, zero) \<in> r \<Longrightarrow> x = zero"
by (metis ANTISYM WELL antisymD well_order_on_domain zero_smallest)

lemma leq_zero[simp]:
assumes "Field r \<noteq> {}"  shows "(x, zero) \<in> r \<longleftrightarrow> x = zero"
using zero_in_Field[OF assms] in_notinI[of x zero] by auto

lemma under_zero[simp]:
assumes "Field r \<noteq> {}" shows "under zero = {zero}"
using assms unfolding under_def by auto

lemma underS_zero[simp,intro]: "underS zero = {}"
unfolding underS_def by auto

lemma isSucc_succ: "aboveS i \<noteq> {} \<Longrightarrow> isSucc (succ i)"
unfolding isSucc_def succ_def by auto

lemma succ_in_diff:
assumes "aboveS i \<noteq> {}"  shows "(i,succ i) \<in> r \<and> succ i \<noteq> i"
using assms suc_greater[of "{i}"] unfolding succ_def AboveS_def aboveS_def Field_def by auto

lemmas succ_in[simp] = succ_in_diff[THEN conjunct1]
lemmas succ_diff[simp] = succ_in_diff[THEN conjunct2]

lemma succ_in_Field[simp]:
assumes "aboveS i \<noteq> {}"  shows "succ i \<in> Field r"
using succ_in[OF assms] unfolding Field_def by auto

lemma succ_not_in:
assumes "aboveS i \<noteq> {}" shows "(succ i, i) \<notin> r"
proof
  assume 1: "(succ i, i) \<in> r"
  hence "succ i \<in> Field r \<and> i \<in> Field r" unfolding Field_def by auto
  hence "(i, succ i) \<in> r \<and> succ i \<noteq> i" using assms by auto
  thus False using 1 by (metis ANTISYM antisymD)
qed

lemma not_isSucc_zero: "\<not> isSucc zero"
proof
  assume *: "isSucc zero"
  then obtain i where "aboveS i \<noteq> {}" and 1: "minim (Field r) = succ i"
  unfolding isSucc_def zero_def by auto
  hence "succ i \<in> Field r" by auto
  with * show False
    by (metis REFL isSucc_def minim_least refl_on_domain
        subset_refl succ_in succ_not_in zero_def)
qed

lemma isLim_zero[simp]: "isLim zero"
  by (metis isLim_def not_isSucc_zero)

lemma succ_smallest:
assumes "(i,j) \<in> r" and "i \<noteq> j"
shows "(succ i, j) \<in> r"
unfolding succ_def apply(rule suc_least)
using assms unfolding Field_def by auto

lemma isLim_supr:
assumes f: "i \<in> Field r" and l: "isLim i"
shows "i = supr (underS i)"
proof(rule equals_supr)
  fix j assume j: "j \<in> Field r" and 1: "\<And> j'. j' \<in> underS i \<Longrightarrow> (j',j) \<in> r"
  show "(i,j) \<in> r" proof(intro in_notinI[OF _ f j], safe)
    assume ji: "(j,i) \<in> r" "j \<noteq> i"
    hence a: "aboveS j \<noteq> {}" unfolding aboveS_def by auto
    hence "i \<noteq> succ j" using l unfolding isLim_def isSucc_def by auto
    moreover have "(succ j, i) \<in> r" using succ_smallest[OF ji] by auto
    ultimately have "succ j \<in> underS i" unfolding underS_def by auto
    hence "(succ j, j) \<in> r" using 1 by auto
    thus False using succ_not_in[OF a] by simp
  qed
qed(insert f, unfold underS_def Field_def, auto)

definition "pred i \<equiv> SOME j. j \<in> Field r \<and> aboveS j \<noteq> {} \<and> succ j = i"

lemma pred_Field_succ:
assumes "isSucc i" shows "pred i \<in> Field r \<and> aboveS (pred i) \<noteq> {} \<and> succ (pred i) = i"
proof-
  obtain j where a: "aboveS j \<noteq> {}" and i: "i = succ j" using assms unfolding isSucc_def by auto
  have 1: "j \<in> Field r" "j \<noteq> i" unfolding Field_def i
  using succ_diff[OF a] a unfolding aboveS_def by auto
  show ?thesis unfolding pred_def apply(rule someI_ex) using 1 i a by auto
qed

lemmas pred_Field[simp] = pred_Field_succ[THEN conjunct1]
lemmas aboveS_pred[simp] = pred_Field_succ[THEN conjunct2, THEN conjunct1]
lemmas succ_pred[simp] = pred_Field_succ[THEN conjunct2, THEN conjunct2]

lemma isSucc_pred_in:
assumes "isSucc i"  shows "(pred i, i) \<in> r"
proof-
  define j where "j = pred i"
  have i: "i = succ j" using assms unfolding j_def by simp
  have a: "aboveS j \<noteq> {}" unfolding j_def using assms by auto
  show ?thesis unfolding j_def[symmetric] unfolding i using succ_in[OF a] .
qed

lemma isSucc_pred_diff:
assumes "isSucc i"  shows "pred i \<noteq> i"
by (metis aboveS_pred assms succ_diff succ_pred)

(* todo: pred maximal, pred injective? *)

lemma succ_inj[simp]:
assumes "aboveS i \<noteq> {}" and "aboveS j \<noteq> {}"
shows "succ i = succ j \<longleftrightarrow> i = j"
proof safe
  assume s: "succ i = succ j"
  {assume "i \<noteq> j" and "(i,j) \<in> r"
   hence "(succ i, j) \<in> r" using assms by (metis succ_smallest)
   hence False using s assms by (metis succ_not_in)
  }
  moreover
  {assume "i \<noteq> j" and "(j,i) \<in> r"
   hence "(succ j, i) \<in> r" using assms by (metis succ_smallest)
   hence False using s assms by (metis succ_not_in)
  }
  ultimately show "i = j" by (metis TOTALS WELL assms(1) assms(2) succ_in_diff well_order_on_domain)
qed

lemma pred_succ[simp]:
assumes "aboveS j \<noteq> {}"  shows "pred (succ j) = j"
unfolding pred_def apply(rule some_equality)
using assms apply(force simp: Field_def aboveS_def)
by (metis assms succ_inj)

lemma less_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "(j, succ i) \<in> r \<longleftrightarrow> (j,i) \<in> r \<or> j = succ i"
apply safe
  apply (metis WELL assms in_notinI well_order_on_domain suc_singl_pred succ_def succ_in_diff)
  apply (metis (opaque_lifting, full_types) REFL TRANS assms max2_def max2_equals1 refl_on_domain succ_in_Field succ_not_in transD)
  apply (metis assms in_notinI succ_in_Field)
done

lemma underS_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "underS (succ i) = under i"
unfolding underS_def under_def by (auto simp: assms succ_not_in)

lemma succ_mono:
assumes "aboveS j \<noteq> {}" and "(i,j) \<in> r"
shows "(succ i, succ j) \<in> r"
by (metis (full_types) assms less_succ succ_smallest)

lemma under_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "under (succ i) = insert (succ i) (under i)"
using less_succ[OF assms] unfolding under_def by auto

definition mergeSL :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where
"mergeSL S L f i \<equiv>
 if isSucc i then S (pred i) (f (pred i))
 else L f i"

subsubsection \<open>Well-order recursion with (zero), succesor, and limit\<close>

definition worecSL :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where "worecSL S L \<equiv> worec (mergeSL S L)"

definition "adm_woL L \<equiv> \<forall>f g i. isLim i \<and> (\<forall>j\<in>underS i. f j = g j) \<longrightarrow> L f i = L g i"

lemma mergeSL:
assumes "adm_woL L"  shows "adm_wo (mergeSL S L)"
unfolding adm_wo_def proof safe
  fix f g :: "'a => 'b" and i :: 'a
  assume 1: "\<forall>j\<in>underS i. f j = g j"
  show "mergeSL S L f i = mergeSL S L g i"
  proof(cases "isSucc i")
    case True
    hence "pred i \<in> underS i" unfolding underS_def using isSucc_pred_in isSucc_pred_diff by auto
    thus ?thesis using True 1 unfolding mergeSL_def by auto
  next
    case False hence "isLim i" unfolding isLim_def by auto
    thus ?thesis using assms False 1 unfolding mergeSL_def adm_woL_def by auto
  qed
qed

lemma worec_fixpoint1: "adm_wo H \<Longrightarrow> worec H i = H (worec H) i"
by (metis worec_fixpoint)

lemma worecSL_isSucc:
assumes a: "adm_woL L" and i: "isSucc i"
shows "worecSL S L i = S (pred i) (worecSL S L (pred i))"
proof-
  let ?H = "mergeSL S L"
  have "worecSL S L i = ?H (worec ?H) i"
  unfolding worecSL_def using worec_fixpoint1[OF mergeSL[OF a]] .
  also have "... = S (pred i) (worecSL S L (pred i))"
  unfolding worecSL_def mergeSL_def using i by simp
  finally show ?thesis .
qed

lemma worecSL_succ:
assumes a: "adm_woL L" and i: "aboveS j \<noteq> {}"
shows "worecSL S L (succ j) = S j (worecSL S L j)"
proof-
  define i where "i = succ j"
  have i: "isSucc i" by (metis i i_def isSucc_succ)
  have ij: "j = pred i" unfolding i_def using assms by simp
  have 0: "succ (pred i) = i" using i by simp
  show ?thesis unfolding ij using worecSL_isSucc[OF a i] unfolding 0 .
qed

lemma worecSL_isLim:
assumes a: "adm_woL L" and i: "isLim i"
shows "worecSL S L i = L (worecSL S L) i"
proof-
  let ?H = "mergeSL S L"
  have "worecSL S L i = ?H (worec ?H) i"
  unfolding worecSL_def using worec_fixpoint1[OF mergeSL[OF a]] .
  also have "... = L (worecSL S L) i"
  using i unfolding worecSL_def mergeSL_def isLim_def by simp
  finally show ?thesis .
qed

definition worecZSL :: "'b \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where "worecZSL Z S L \<equiv> worecSL S (\<lambda> f a. if a = zero then Z else L f a)"

lemma worecZSL_zero:
assumes a: "adm_woL L"
shows "worecZSL Z S L zero = Z"
proof-
  let ?L = "\<lambda> f a. if a = zero then Z else L f a"
  have "worecZSL Z S L zero = ?L (worecZSL Z S L) zero"
  unfolding worecZSL_def apply(rule worecSL_isLim)
  using assms unfolding adm_woL_def by auto
  also have "... = Z" by simp
  finally show ?thesis .
qed

lemma worecZSL_succ:
assumes a: "adm_woL L" and i: "aboveS j \<noteq> {}"
shows "worecZSL Z S L (succ j) = S j (worecZSL Z S L j)"
unfolding worecZSL_def apply(rule  worecSL_succ)
using assms unfolding adm_woL_def by auto

lemma worecZSL_isLim:
assumes a: "adm_woL L" and "isLim i" and "i \<noteq> zero"
shows "worecZSL Z S L i = L (worecZSL Z S L) i"
proof-
  let ?L = "\<lambda> f a. if a = zero then Z else L f a"
  have "worecZSL Z S L i = ?L (worecZSL Z S L) i"
  unfolding worecZSL_def apply(rule worecSL_isLim)
  using assms unfolding adm_woL_def by auto
  also have "... = L (worecZSL Z S L) i" using assms by simp
  finally show ?thesis .
qed

subsubsection \<open>Well-order succ-lim induction\<close>

lemma ord_cases:
obtains j where "i = succ j" and "aboveS j \<noteq> {}"  | "isLim i"
by (metis isLim_def isSucc_def)

lemma well_order_inductSL[case_names Suc Lim]:
assumes SUCC: "\<And>i. \<lbrakk>aboveS i \<noteq> {}; P i\<rbrakk> \<Longrightarrow> P (succ i)" and
LIM: "\<And>i. \<lbrakk>isLim i; \<And>j. j \<in> underS i \<Longrightarrow> P j\<rbrakk> \<Longrightarrow> P i"
shows "P i"
proof(induction rule: well_order_induct)
  fix i assume 0:  "\<forall>j. j \<noteq> i \<and> (j, i) \<in> r \<longrightarrow> P j"
  show "P i" proof(cases i rule: ord_cases)
    fix j assume i: "i = succ j" and j: "aboveS j \<noteq> {}"
    hence "j \<noteq> i \<and> (j, i) \<in> r" by (metis  succ_diff succ_in)
    hence 1: "P j" using 0 by simp
    show "P i" unfolding i apply(rule SUCC) using 1 j by auto
  qed(insert 0 LIM, unfold underS_def, auto)
qed

lemma well_order_inductZSL[case_names Zero Suc Lim]:
assumes ZERO: "P zero"
and SUCC: "\<And>i. \<lbrakk>aboveS i \<noteq> {}; P i\<rbrakk> \<Longrightarrow> P (succ i)" and
LIM: "\<And>i. \<lbrakk>isLim i; i \<noteq> zero; \<And>j. j \<in> underS i \<Longrightarrow> P j\<rbrakk> \<Longrightarrow> P i"
shows "P i"
apply(induction rule: well_order_inductSL) using assms by auto

(* Succesor and limit ordinals *)
definition "isSuccOrd \<equiv> \<exists> j \<in> Field r. \<forall> i \<in> Field r. (i,j) \<in> r"
definition "isLimOrd \<equiv> \<not> isSuccOrd"

lemma isLimOrd_succ:
assumes isLimOrd and "i \<in> Field r"
shows "succ i \<in> Field r"
using assms unfolding isLimOrd_def isSuccOrd_def
by (metis REFL in_notinI refl_on_domain succ_smallest)

lemma isLimOrd_aboveS:
assumes l: isLimOrd and i: "i \<in> Field r"
shows "aboveS i \<noteq> {}"
proof-
  obtain j where "j \<in> Field r" and "(j,i) \<notin> r"
  using assms unfolding isLimOrd_def isSuccOrd_def by auto
  hence "(i,j) \<in> r \<and> j \<noteq> i" by (metis i max2_def max2_greater)
  thus ?thesis unfolding aboveS_def by auto
qed

lemma succ_aboveS_isLimOrd:
assumes "\<forall> i \<in> Field r. aboveS i \<noteq> {} \<and> succ i \<in> Field r"
shows isLimOrd
unfolding isLimOrd_def isSuccOrd_def proof safe
  fix j assume j: "j \<in> Field r" "\<forall>i\<in>Field r. (i, j) \<in> r"
  hence "(succ j, j) \<in> r" using assms by auto
  moreover have "aboveS j \<noteq> {}" using assms j unfolding aboveS_def by auto
  ultimately show False by (metis succ_not_in)
qed

lemma isLim_iff:
assumes l: "isLim i" and j: "j \<in> underS i"
shows "\<exists> k. k \<in> underS i \<and> j \<in> underS k"
proof-
  have a: "aboveS j \<noteq> {}" using j unfolding underS_def aboveS_def by auto
  show ?thesis apply(rule exI[of _ "succ j"]) apply safe
  using assms a unfolding underS_def isLim_def
  apply (metis (lifting, full_types) isSucc_def mem_Collect_eq succ_smallest)
  by (metis (lifting, full_types) a mem_Collect_eq succ_diff succ_in)
qed

end (* context wo_rel *)

abbreviation "zero \<equiv> wo_rel.zero"
abbreviation "succ \<equiv> wo_rel.succ"
abbreviation "pred \<equiv> wo_rel.pred"
abbreviation "isSucc \<equiv> wo_rel.isSucc"
abbreviation "isLim \<equiv> wo_rel.isLim"
abbreviation "isLimOrd \<equiv> wo_rel.isLimOrd"
abbreviation "isSuccOrd \<equiv> wo_rel.isSuccOrd"
abbreviation "adm_woL \<equiv> wo_rel.adm_woL"
abbreviation "worecSL \<equiv> wo_rel.worecSL"
abbreviation "worecZSL \<equiv> wo_rel.worecZSL"

subsection \<open>Projections of wellorders\<close>

definition "oproj r s f \<equiv> Field s \<subseteq> f ` (Field r) \<and> compat r s f"

lemma oproj_in:
assumes "oproj r s f" and "(a,a') \<in> r"
shows "(f a, f a') \<in> s"
using assms unfolding oproj_def compat_def by auto

lemma oproj_Field:
assumes f: "oproj r s f" and a: "a \<in> Field r"
shows "f a \<in> Field s"
using oproj_in[OF f] a unfolding Field_def by auto

lemma oproj_Field2:
assumes f: "oproj r s f" and a: "b \<in> Field s"
shows "\<exists> a \<in> Field r. f a = b"
using assms unfolding oproj_def by auto

lemma oproj_under:
assumes f:  "oproj r s f" and a: "a \<in> under r a'"
shows "f a \<in> under s (f a')"
using oproj_in[OF f] a unfolding under_def by auto

(* An ordinal is embedded in another whenever it is embedded as an order
(not necessarily as initial segment):*)
theorem embedI:
assumes r: "Well_order r" and s: "Well_order s"
and f: "\<And> a. a \<in> Field r \<Longrightarrow> f a \<in> Field s \<and> f ` underS r a \<subseteq> underS s (f a)"
shows "\<exists> g. embed r s g"
proof-
  interpret r: wo_rel r by unfold_locales (rule r)
  interpret s: wo_rel s by unfold_locales (rule s)
  let ?G = "\<lambda> g a. suc s (g ` underS r a)"
  define g where "g = worec r ?G"
  have adm: "adm_wo r ?G" unfolding r.adm_wo_def image_def by auto
  (*  *)
  {fix a assume "a \<in> Field r"
   hence "bij_betw g (under r a) (under s (g a)) \<and>
          g a \<in> under s (f a)"
   proof(induction a rule: r.underS_induct)
     case (1 a)
     hence a: "a \<in> Field r"
     and IH1a: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> inj_on g (under r a1)"
     and IH1b: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g ` under r a1 = under s (g a1)"
     and IH2: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> under s (f a1)"
     unfolding underS_def Field_def bij_betw_def by auto
     have fa: "f a \<in> Field s" using f[OF a] by auto
     have g: "g a = suc s (g ` underS r a)"
       using r.worec_fixpoint[OF adm] unfolding g_def fun_eq_iff by blast
     have A0: "g ` underS r a \<subseteq> Field s"
     using IH1b by (metis IH2 image_subsetI in_mono under_Field)
     {fix a1 assume a1: "a1 \<in> underS r a"
      from IH2[OF this] have "g a1 \<in> under s (f a1)" .
      moreover have "f a1 \<in> underS s (f a)" using f[OF a] a1 by auto
      ultimately have "g a1 \<in> underS s (f a)" by (metis s.ANTISYM s.TRANS under_underS_trans)
     }
     hence "f a \<in> AboveS s (g ` underS r a)" unfolding AboveS_def
     using fa by simp (metis (lifting, full_types) mem_Collect_eq underS_def)
     hence A: "AboveS s (g ` underS r a) \<noteq> {}" by auto
     have B: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> underS s (g a)"
     unfolding g apply(rule s.suc_underS[OF A0 A]) by auto
     {fix a1 a2 assume a2: "a2 \<in> underS r a" and 1: "a1 \<in> underS r a2"
      hence a12: "{a1,a2} \<subseteq> under r a2" and "a1 \<noteq> a2" using r.REFL a
      unfolding underS_def under_def refl_on_def Field_def by auto
      hence "g a1 \<noteq> g a2" using IH1a[OF a2] unfolding inj_on_def by auto
      hence "g a1 \<in> underS s (g a2)" using IH1b[OF a2] a12
      unfolding underS_def under_def by auto
     } note C = this
     have ga: "g a \<in> Field s" unfolding g using s.suc_inField[OF A0 A] .
     have aa: "a \<in> under r a"
     using a r.REFL unfolding under_def underS_def refl_on_def by auto
     show ?case proof safe
       show "bij_betw g (under r a) (under s (g a))" unfolding bij_betw_def proof safe
         show "inj_on g (under r a)" proof(rule r.inj_on_Field)
           fix a1 a2 assume "a1 \<in> under r a" and a2: "a2 \<in> under r a" and a1: "a1 \<in> underS r a2"
           hence a22: "a2 \<in> under r a2" and a12: "a1 \<in> under r a2" "a1 \<noteq> a2"
           using a r.REFL unfolding under_def underS_def refl_on_def by auto
           show "g a1 \<noteq> g a2"
           proof(cases "a2 = a")
             case False hence "a2 \<in> underS r a"
             using a2 unfolding underS_def under_def by auto
             from IH1a[OF this] show ?thesis using a12 a22 unfolding inj_on_def by auto
           qed(insert B a1, unfold underS_def, auto)
         qed(unfold under_def Field_def, auto)
       next
         fix a1 assume a1: "a1 \<in> under r a"
         show "g a1 \<in> under s (g a)"
         proof(cases "a1 = a")
           case True thus ?thesis
           using ga s.REFL unfolding refl_on_def under_def by auto
         next
           case False
           hence a1: "a1 \<in> underS r a" using a1 unfolding underS_def under_def by auto
           thus ?thesis using B unfolding underS_def under_def by auto
         qed
       next
         fix b1 assume b1: "b1 \<in> under s (g a)"
         show "b1 \<in> g ` under r a"
         proof(cases "b1 = g a")
           case True thus ?thesis using aa by auto
         next
           case False
           hence "b1 \<in> underS s (g a)" using b1 unfolding underS_def under_def by auto
           from s.underS_suc[OF this[unfolded g] A0]
           obtain a1 where a1: "a1 \<in> underS r a" and b1: "b1 \<in> under s (g a1)" by auto
           obtain a2 where "a2 \<in> under r a1" and b1: "b1 = g a2" using IH1b[OF a1] b1 by auto
           hence "a2 \<in> under r a" using a1
           by (metis r.ANTISYM r.TRANS in_mono underS_subset_under under_underS_trans)
           thus ?thesis using b1 by auto
         qed
       qed
     next
       have "(g a, f a) \<in> s" unfolding g proof(rule s.suc_least[OF A0])
         fix b1 assume "b1 \<in> g ` underS r a"
         then obtain a1 where a1: "b1 = g a1" and a1: "a1 \<in> underS r a" by auto
         hence "b1 \<in> underS s (f a)"
         using a by (metis \<open>\<And>a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> underS s (f a)\<close>)
         thus "f a \<noteq> b1 \<and> (b1, f a) \<in> s" unfolding underS_def by auto
       qed(insert fa, auto)
       thus "g a \<in> under s (f a)" unfolding under_def by auto
     qed
   qed
  }
  thus ?thesis unfolding embed_def by auto
qed

corollary ordLeq_def2:
  "r \<le>o s \<longleftrightarrow> Well_order r \<and> Well_order s \<and>
               (\<exists> f. \<forall> a \<in> Field r. f a \<in> Field s \<and> f ` underS r a \<subseteq> underS s (f a))"
using embed_in_Field[of r s] embed_underS2[of r s] embedI[of r s]
unfolding ordLeq_def by fast

lemma iso_oproj:
  assumes r: "Well_order r" and s: "Well_order s" and f: "iso r s f"
  shows "oproj r s f"
using assms unfolding oproj_def
by (subst (asm) iso_iff3) (auto simp: bij_betw_def)

theorem oproj_embed:
assumes r: "Well_order r" and s: "Well_order s" and f: "oproj r s f"
shows "\<exists> g. embed s r g"
proof (rule embedI[OF s r, of "inv_into (Field r) f"], unfold underS_def, safe)
  fix b assume "b \<in> Field s"
  thus "inv_into (Field r) f b \<in> Field r" using oproj_Field2[OF f] by (metis imageI inv_into_into)
next
  fix a b assume "b \<in> Field s" "a \<noteq> b" "(a, b) \<in> s"
    "inv_into (Field r) f a = inv_into (Field r) f b"
  with f show False by (auto dest!: inv_into_injective simp: Field_def oproj_def)
next
  fix a b assume *: "b \<in> Field s" "a \<noteq> b" "(a, b) \<in> s"
  { assume "(inv_into (Field r) f a, inv_into (Field r) f b) \<notin> r"
    moreover
    from *(3) have "a \<in> Field s" unfolding Field_def by auto
    with *(1,2) have
      "inv_into (Field r) f a \<in> Field r" "inv_into (Field r) f b \<in> Field r"
      "inv_into (Field r) f a \<noteq> inv_into (Field r) f b"
      by (auto dest!: oproj_Field2[OF f] inv_into_injective intro!: inv_into_into)
    ultimately have "(inv_into (Field r) f b, inv_into (Field r) f a) \<in> r"
      using r by (auto simp: well_order_on_def linear_order_on_def total_on_def)
    with f[unfolded oproj_def compat_def] *(1) \<open>a \<in> Field s\<close>
      f_inv_into_f[of b f "Field r"] f_inv_into_f[of a f "Field r"]
      have "(b, a) \<in> s" by (metis in_mono)
    with *(2,3) s have False
      by (auto simp: well_order_on_def linear_order_on_def partial_order_on_def antisym_def)
  } thus "(inv_into (Field r) f a, inv_into (Field r) f b) \<in> r" by blast
qed

corollary oproj_ordLeq:
  assumes r: "Well_order r" and s: "Well_order s" and f: "oproj r s f"
  shows "s \<le>o r"
  using oproj_embed[OF assms] r s unfolding ordLeq_def by auto

end


theory T36
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end