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

theory CompositionSeries
imports
  MaximalNormalSubgroups Secondary_Sylow.SndSylow
begin

hide_const (open) Divisibility.prime

section \<open>Normal series and Composition series\<close>

subsection \<open>Preliminaries\<close>

text \<open>A subgroup which is unique in cardinality is normal:\<close>

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
  define Q where "Q = (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 \<open>A group whose order is the product of two distinct
primes $p$ and $q$ where $p < q$ has a unique subgroup of size $q$:\<close>

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_nat_iff)
  define calM where "calM = {s. s \<subseteq> carrier G \<and> card s = q ^ 1}"
  define RelM where "RelM = {(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)
     then have "card (subgroups_of_size q) = p \<or> card (subgroups_of_size q) = 1"
       using primep by (auto simp add: prime_nat_iff)
     ultimately have "card (subgroups_of_size q) = 1" using pq
       by auto
     with Q P show "P = Q" by (auto simp:card_Suc_eq)
  qed
qed

text \<open>... And this unique subgroup is normal.\<close>

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 \<open>The trivial subgroup is normal in every group.\<close>

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 \<open>Normal Series\<close>

text \<open>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.\<close>

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 \<open>For every group there is a "trivial" normal series consisting
only of the group itself and its trivial subgroup.\<close>

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 \<open>We can also show that the normal series presented above is the only such with
a length of two:\<close>

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 "\<GG> ! i = [{\<one>}, carrier G] ! i" if i: "i < length \<GG>" for i
  proof -
    have "i = 0 \<or> i = 1" using that assms 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 \<open>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}.\<close>

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 \<open>All entries of a normal series for $G$ are subgroups of $G$.\<close>

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>" by simp
    hence ii: "i + 1 = length \<GG> - 1" 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"
      using incl_subgroup by blast
  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 \<open>The second to last entry of a normal series is a normal subgroup of G.\<close>

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
  have "1 + (1 + (length \<GG> - (1 + 1))) = length \<GG>"
    using True le_add_diff_inverse by presburger
  then have "\<GG> ! (length \<GG> - 2) \<lhd> G\<lparr>carrier :=  \<GG> ! (length \<GG> - 1)\<rparr>"
    by (metis \<open>\<GG> ! (length \<GG> - 2) \<lhd> G \<lparr>carrier := \<GG> ! (length \<GG> - 2 + 1)\<rparr>\<close> add.commute add_diff_cancel_left' one_add_one)
  with notempty last show ?thesis using last_conv_nth by force
qed

text \<open>Just like the expansion of normal series, every prefix of a normal series is again a normal series.\<close>

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 simp: hd del:equalityI)
  apply (simp add: is_group normal_series_subgroups subgroup.subgroup_is_group)
 apply (simp add: last_conv_nth min.absorb2 notempty)
using assms(1) normal apply simp
done

text \<open>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}.\<close>

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 -
  define H where "H = (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 \<open>The following defines the list of all quotient groups of the normal series:\<close>

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 \<open>The list of quotient groups has one less entry than the series itself:\<close>

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 (simp add: ac_simps)
  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 \<open>The next lemma transports the constituting properties of a normal series
along an isomorphism of groups.\<close>

lemma (in normal_series) normal_series_iso:
  assumes H: "group H"
  assumes iso: "\<Psi> \<in> iso G 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 ((`) \<Psi>) \<GG>) = {\<one>\<^bsub>H\<^esub>}".
next
  show "last (map ((`) \<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 ((`) \<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 ((`) \<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> iso (G\<lparr>carrier := \<GG> ! Suc i\<rparr>) (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 (simp add: H iso subgroup.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 cong del: image_cong_simp)
    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 \<open>Composition Series\<close>

text \<open>A composition series is a normal series where all consecutive factor groups are simple:\<close>

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 \<open>A composition series for a group $G$ has length one if and only if $G$ is the trivial group.\<close>

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 \<open>The inner elements of a composition series may not consist of the trivial subgroup or the
group itself.\<close>

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 \<open>A composition series of a simple group always is its trivial one.\<close>

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> iso (G Mod {\<one>}) 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 (simp add: Suc_leI antisym notempty)
    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)
    define k where "k = 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 \<open>\<not> length \<GG> \<le> 2\<close> 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 \<open>Two consecutive elements in a composition series are distinct.\<close>

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.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 \<open>The normal series for groups of order @{term "p * q"} is even a composition series:\<close>

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 -
  define H where "H = (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_eq_q: "order (G\<lparr>carrier := H\<rparr> Mod {\<one>}) = q"
      using Hgroup.trivial_factor_iso iso_same_order by auto
    have "normal {\<one>} (G\<lparr>carrier := H\<rparr>)"
      by (simp add: HsubG group.normal_restrict_supergroup subgroup.one_closed trivial_subgroup_is_normal)
    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_eq_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 not_prime_0)
    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 \<open>q \<noteq> 0\<close> 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 \<open>Prefixes of composition series are also composition series.\<close>

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 \<open>The second element in a composition series is simple group.\<close>

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 \<open>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.\<close>

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 \<open>The second to last entry of a normal series is not only a normal subgroup but
  actually even a \emph{maximal} normal subgroup.\<close>

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
  define G' where "G' = \<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.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.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 \<open>For the next lemma we need a few facts about removing adjacent duplicates.\<close>

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)
  then have "xs \<noteq> []"
    by auto
  then obtain y xs' where xs: "xs = y # xs'"
    by (cases xs) blast
  from \<open>xs \<noteq> []\<close> 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

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 (3 x y xs i)
  thus ?case by (cases i, cases "x = y") (simp, auto simp: hd_conv_nth[symmetric])
qed simp_all

text \<open>Intersecting each entry of a composition series with a normal subgroup of $G$ and removing
  all adjacent duplicates yields another composition series.\<close>

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
  \<comment> \<open>Show, that removing adjacent duplicates doesn't result in an empty list.\<close>
  assume "remdups_adj (map ((\<inter>) K) \<GG>) = []"
  hence "map ((\<inter>) K) \<GG> = []" by (metis remdups_adj_Nil_iff)
  hence "\<GG> = []" by (metis Nil_is_map_conv)
  with notempty show False..
next
  \<comment> \<open>Show, that the head of the reduced list is still the trivial group\<close>
  have "\<GG> = {\<one>} # tl \<GG>" using notempty hd by (metis list.sel(1,3) neq_Nil_conv)
  hence "map ((\<inter>) K) \<GG> = map ((\<inter>) K) ({\<one>} # tl \<GG>)" by simp
  hence "remdups_adj (map ((\<inter>) K) \<GG>) = remdups_adj ((K \<inter> {\<one>}) # (map ((\<inter>) K) (tl \<GG>)))" by simp
  also have "\<dots> = (K \<inter> {\<one>}) # tl (remdups_adj ((K \<inter> {\<one>}) # (map ((\<inter>) K) (tl \<GG>))))" by simp
  finally have "hd (remdups_adj (map ((\<inter>) K) \<GG>)) = K \<inter> {\<one>}" using list.sel(1) by metis
  thus "hd (remdups_adj (map ((\<inter>) K) \<GG>)) = {\<one>\<^bsub>G\<lparr>carrier := K\<rparr>\<^esub>}"
    using KG normal_imp_subgroup subgroup.one_closed by force
next
  \<comment> \<open>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.\<close>
  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 ((\<inter>) K) \<GG>) = map ((\<inter>) K) ((carrier G) # tl (rev \<GG>))" by (metis rev_map)
  hence rev: "rev (map ((\<inter>) K) \<GG>) = (K \<inter> (carrier G)) # (map ((\<inter>) K) (tl (rev \<GG>)))" by simp
  have "last (remdups_adj (map ((\<inter>) K) \<GG>)) = hd (rev (remdups_adj (map ((\<inter>) K) \<GG>)))"
    by (metis hd_rev map_is_Nil_conv notempty remdups_adj_Nil_iff)
  also have "\<dots> = hd (remdups_adj (rev (map ((\<inter>) K) \<GG>)))" by (metis remdups_adj_rev)
  also have "\<dots> = hd (remdups_adj ((K \<inter> (carrier G)) # (map ((\<inter>) K) (tl (rev \<GG>)))))" by (metis rev)
  also have "\<dots> = hd ((K \<inter> (carrier G)) # (remdups_adj ((K \<inter> (carrier G)) # (map ((\<inter>) K) (tl (rev \<GG>))))))" by (metis list.sel(1) remdups_adj_Cons_alt)
  also have "\<dots> = K" using KG normal_imp_subgroup subgroup.subset by force
  finally show "last (remdups_adj (map ((\<inter>) K) \<GG>)) = carrier (G\<lparr>carrier := K\<rparr>)" by auto
next
  \<comment> \<open>The induction step, using the second isomorphism theorem for groups.\<close>
  fix j
  assume j: "j + 1 < length (remdups_adj (map ((\<inter>) K) \<GG>))"
  have KGnotempty: "(map ((\<inter>) K) \<GG>) \<noteq> []" using notempty by (metis Nil_is_map_conv)
  with j obtain i where i: "i + 1 < length (map ((\<inter>) K) \<GG>)"
    "(remdups_adj (map ((\<inter>) K) \<GG>)) ! j = (map ((\<inter>) K) \<GG>) ! i"
    "(remdups_adj (map ((\<inter>) K) \<GG>)) ! (j + 1) = (map ((\<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.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 ((\<inter>) K) \<GG>) ! j \<lhd> G\<lparr>carrier := K, carrier := remdups_adj (map ((\<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 set_mult_consistent by fastforce
  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> iso  (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (\<GG> ! i \<inter> (K \<inter> \<GG> ! (i + 1))))
             (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> iso  (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! (i + 1) \<inter> \<GG> ! i))
                  (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> iso (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> (\<GG> ! (i + 1) \<inter> \<GG> ! i)))
                 (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> iso (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i))
                 (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> iso (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i))
                   (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 ((\<inter>) K) \<GG>) ! (j + 1)\<rparr> Mod remdups_adj (map ((\<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> iso (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) (G\<lparr>carrier := \<GG> ! i\<rparr> Mod \<GG> ! i)" by auto
    moreover obtain \<psi> where "\<psi> \<in> iso (G\<lparr>carrier := \<GG> ! i\<rparr> Mod (carrier (G\<lparr>carrier := \<GG> ! i\<rparr>))) (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> iso (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) (G\<lparr>carrier := {\<one>}\<rparr>)"
      using iso_set_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 (meson iso_same_order)
    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 blast
    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 ((\<inter>) K) \<GG>)) ! j = (remdups_adj (map ((\<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 ((\<inter>) K) \<GG>) ! Suc j\<rparr> Mod remdups_adj (map ((\<inter>) K) \<GG>) ! j)"..
  next
    assume "\<GG> ! i <#> K \<inter> \<GG> ! Suc i = \<GG> ! Suc i"
    with \<phi> have "\<phi> \<in> iso (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i)"
      by auto
    then obtain \<phi>' where "\<phi>' \<in> iso (G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i) (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i))"
      using KGsiKGigroup group.iso_set_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 ((\<inter>) K) \<GG>) ! Suc j\<rparr> Mod remdups_adj (map ((\<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 \<open>Suc i < length \<HH>\<close> 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.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


theory Digits_int
  imports Complex_Main
begin

text \<open> First, we look at some useful lemmas for splitting sums. \<close>
lemma split_sum_first_elt_less: assumes "n<m"
  shows "(\<Sum>i\<in>{n..<m}. f i) = f n + (\<Sum>i\<in>{Suc n ..<m}. f i)"
  using sum.atLeast_Suc_lessThan assms by blast

lemma split_sum_mid_less: assumes "i<(n::nat)"
  shows "(\<Sum>j<n. f j) = (\<Sum>j<i. f j) + (\<Sum>j=i..<n. f j)"
proof -
  have "(\<Sum>j<n. f j) = (\<Sum>j\<in>{..<i} \<union> {i..<n}. f j)"
    using \<open>i < n\<close> by (intro sum.cong) auto
  also have "\<dots> = (\<Sum>j<i. f j) + (\<Sum>j=i..<n. f j)"
    by (subst sum.union_disjoint) auto
  finally show "(\<Sum>j<n. f j) = (\<Sum>j<i. f j) + (\<Sum>j=i..<n. f j)" .
qed
text \<open>In order to use representation of numbers in a basis \<open>base\<close> and to calculate the conversion
to and from integers, we introduce the following locale.\<close>
locale digits =
  fixes base :: int
  assumes base_pos: "base > 0"
begin

text \<open>Conversion from basis base to integers: \<open>from_digits n d\<close>

\begin{tabular}{lcp{8cm}}
  n:& \<open>nat\<close>& length of representation in basis base\\
  d:& \<open>nat \<Rightarrow> nat\<close>& function of digits in basis base where \<open>d i\<close> is the $i$-th digit in basis base\\
  output:& \<open>nat\<close>& natural number corresponding to $d(n-1) \dots d(0)$ as integer\\
\end{tabular}
\<close>
fun from_digits :: "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat" where
  "from_digits 0 d = 0"
| "from_digits (Suc n) d = d 0 + nat base * from_digits n (d \<circ> Suc)"

text \<open>Alternative definition using sum:\<close>
lemma from_digits_altdef: "from_digits n d = (\<Sum>i<n. d i * nat base ^ i)"
  by (induction n d rule: from_digits.induct)
     (auto simp add: sum.lessThan_Suc_shift o_def sum_distrib_left
       sum_distrib_right mult_ac simp del: sum.lessThan_Suc)

lemma int_from_digits:
  "int (from_digits n d) = (\<Sum>i<n. int (d i) * base ^ i)"
unfolding from_digits_altdef using base_pos by auto

text \<open>Digit in basis base of some integer number: \<open>digit x i\<close>

\begin{tabular}{lcp{8cm}}
  x:& \<open>nat\<close>& integer\\
  i:& \<open>nat\<close>& index\\
  output:& \<open>nat\<close>& $i$-th digit of representation in basis base of $x$\\
\end{tabular}
\<close>
fun digit :: "int \<Rightarrow> nat \<Rightarrow> int" where
  "digit x 0 = \<bar>x\<bar> mod base"
| "digit x (Suc i) = digit (\<bar>x\<bar> div base) i"

text \<open>Alternative definition using divisor and modulo:\<close>
lemma digit_altdef: "digit x i = ( \<bar>x\<bar> div (base ^ i)) mod base"
proof (induction x i rule: digit.induct)
  case (2 x i)
  show ?case by (subst digit.simps(2), subst 2) (smt (verit, ccfv_SIG) base_pos
        pos_imp_zdiv_neg_iff power.simps(2) zdiv_zmult2_eq zero_less_power)
qed simp

text \<open>Every digit must be smaller that the base.\<close>
lemma digit_less_base: "digit x i < base"
  using base_pos by (auto simp: digit_altdef)

text \<open>A representation in basis \<open>base\<close> of length $n$ must be less than $\<open>base\<close> ^ n$.\<close>
lemma from_digits_less:
  assumes "\<forall>i<n. d i < base"
  shows "from_digits n d < base ^ n"
using assms proof (induct n d rule: from_digits.induct)
  case (2 n d)
  have "from_digits n (d \<circ> Suc) \<le> base ^ n -1" using 2
    by (simp add: "2.hyps")
  moreover have "d 0 \<le> base -1" using 2 by simp
  ultimately have "d 0 + base * from_digits n (d \<circ> Suc) \<le>
      base - 1 + base * (base^(n) - 1)"
    by (smt (verit, ccfv_SIG) base_pos mult_less_cancel_left_pos)
  then show "from_digits (Suc n) d < base ^ Suc n"
    using base_pos by (simp add: right_diff_distrib)
qed auto

text \<open>Lemmas for \<open>mod\<close> and \<open>div\<close> in number systems of basis \<open>base\<close>:\<close>
lemma mod_base:  assumes "\<And>i. i<n \<Longrightarrow> d i < base" "n>0"
  shows "from_digits n d mod base = d 0 "
proof -
  have "(\<Sum>i<n. d i * base ^ i) mod base =
          (\<Sum>i<n. d i * base ^ i mod base) mod base"
  by (subst mod_sum_eq[symmetric]) simp
  then show ?thesis using assms
    sum.lessThan_Suc_shift[of "(\<lambda>i. d i * base ^ i mod base)" "n-1"]
    int_from_digits by simp
qed

lemma mod_base_i:
  assumes "\<And>i. i<n \<Longrightarrow> (d i ::nat) < base" "n>0" "i<n"
  shows "(\<Sum>j=i..<n. d j * base ^ (j-i)) mod base = d i "
proof -
  have eq: "(\<Sum>j=i..<n. d j * base ^ (j-i)) mod base =
        (\<Sum>j=i..<n. d j * base ^ (j-i) mod base) mod base"
    by (subst mod_sum_eq[symmetric]) simp
  then show ?thesis  using assms
    split_sum_first_elt_less[where  f = "(\<lambda>j. d j * base ^ (j-i) mod base)"]
    int_from_digits by auto
qed

lemma div_base_i:
  assumes "\<And>i. i<n \<Longrightarrow> (d i::nat) < base" "n>0" "i<n"
  shows "from_digits n d div (base ^i) = (\<Sum>j=i..<n. d j * base ^ (j-i))"
  unfolding int_from_digits proof -
  have base_exp: "base^(j) =  base^(j-i) * base^i"
    if "j\<in>{i..<n}" for j
    by (metis Nat.add_diff_assoc2 add_diff_cancel_right' atLeastLessThan_iff
        power_add that)
  have first:"(\<Sum>j<i. d j * base ^ j)< base ^ i"
    using assms from_digits_less[where n="i"]
    unfolding int_from_digits by auto
  have ge_0: "0 \<le> (\<Sum>j<i. int (d j) * base ^ j)" using base_pos
  by (metis int_from_digits of_nat_0_le_iff)
  have eq: "(\<Sum>j<n. d j * base ^ j) =
          (\<Sum>j<i. d j * base ^ j) + (\<Sum>j=i..<n. d j * base ^ j)"
    using assms split_sum_mid_less[where f="(\<lambda>j. d j * base^j)"] by auto
  have split_sum: "(\<Sum>j<n. d j * base ^ j) =
      (\<Sum>j<i. d j * base ^ j) + base^i * (\<Sum>j=i..<n. d j * base ^ (j-i))"
    unfolding eq using base_exp mult.assoc sum_distrib_right
    by (smt (z3) mult.commute sum.cong)
  show "(\<Sum>i<n. d i * base ^ i) div base ^ i =
             (\<Sum>j = i..<n. d j * base ^ (j - i))"
    unfolding split_sum using base_pos first div_pos_pos_trivial[OF ge_0 first]
    by (subst div_mult_self2, auto)
qed

text \<open>Conversions are inverse to each other.\<close>
lemma digit_from_digits:
  assumes "\<And>j. j<n \<Longrightarrow> d j < base" "n>0" "i<n"
  shows   "digit (from_digits n d) i = d i"
  using assms proof (cases "i=0")
  case True
  then show ?thesis
  using assms(1) assms(3) mod_base by force
next
  case False
  have "from_digits n d div base^i mod base = d i"
    using assms by (auto simp add: div_base_i mod_base_i)
  then show "digit (from_digits n d) i = d i"
    unfolding digit_altdef by auto
qed

lemma div_distrib: assumes "i<n"
  shows "(a*base^n + b) div base^i mod base = b div base^i mod base"
proof -
  have "base^i dvd (a*base^n)" using assms
    by (simp add: le_imp_power_dvd)
  moreover have "a*base^n div base^i mod base = 0"
    by (metis Suc_leI assms dvd_imp_mod_0 dvd_mult
        dvd_mult_imp_div le_imp_power_dvd power_Suc)
  ultimately show ?thesis
    by (metis add.right_neutral div_mult_mod_eq
        div_plus_div_distrib_dvd_left mod_mult_self3)
qed

lemma(in digits) digits_eq_0:
  assumes "x = 0"
  shows "digit x i = 0"
by (simp add: assms digit_altdef)
end

lemma split_digits_eq_zero:
  assumes "a + base * b = 0" "\<bar>a\<bar><base" "(base::int)>2"
  shows "a = 0 \<and> b=0"
using assms proof (cases "b = 0")
  case True
  then show "a=0 \<and> b=0" using assms by auto
next
  case False
  then have "\<bar>b\<bar> \<ge> 1" by auto
  then have "\<bar>a\<bar> < \<bar>base * b\<bar>" using assms(2) assms(3)
    by (subst abs_mult) (smt (verit) mult_le_cancel_left1)
  moreover have "\<bar>a\<bar> = \<bar>base * b\<bar>" using assms(1) by auto
  ultimately have False by auto
  then show ?thesis by auto
qed

lemma respresentation_in_basis_eq_zero:
  assumes "(\<Sum>i<n. c i * base^i) = 0" "(base::int) > 2" "\<And>i. i<n \<Longrightarrow> \<bar>c i\<bar> < base" "i<n"
  shows "c i = 0"
using assms proof (induction n arbitrary: i c)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have eq_0: "c 0 + base * (\<Sum>i<n. c (i+1) * base ^ i) = 0"
    using Suc(2) unfolding sum.lessThan_Suc_shift power_Suc sum.cong[of "{..<n}" "{..<n}"
      "(\<lambda>i. c (Suc i) * (base * base ^ i))" "(\<lambda>i. base * (c (n + 1) * base ^ n))"]
    by (subst sum_distrib_left)(metis (no_types, lifting) Suc_eq_plus1 mult.left_commute
      mult_cancel_left1 power_0 sum.cong)
  have "c 0 = 0 " and right: "(\<Sum>i<n. c (i+1) * base ^ i) = 0"
    using split_digits_eq_zero[OF eq_0 Suc(4)[of 0] Suc(3)] by auto
  have lt_n: "c (i + 1) = 0" if "i<n" for i using Suc(4)
    by (subst Suc(1)[OF right \<open>2<base\<close> _ \<open>i<n\<close>], auto)
  then show ?case
  proof (cases "i=0")
    case False
    then show ?thesis using Suc(5) lt_n less_Suc_eq_0_disj by auto
  qed (use \<open>c 0 = 0\<close> in \<open>auto\<close>)
qed

end


 theory Q2
imports Main
begin

theorem ex1 :
  assumes rpq: "R⟶P∨Q"
 and rfalseq: "R⟶¬Q"
    shows "R⟶P"
proof -
   have rp: "R⟹P"
   proof -
     assume r: "R"
     from rpq and r have  pq: "P∨Q" by (rule impE)
     from rfalseq and r have nq: "¬Q" by (rule impE)

     have npfalse: "¬P ⟹ False"
     proof -
       assume np: "¬P"

       have falseq: "Q ⟹ False"
       proof -
         assume q: "Q"
         from nq and q show "False" by (rule notE)
       qed

       have pfalse: "P ⟹ False"
       proof -
         assume p: "P"
         from np and p show "False" by (rule notE)
       qed

       from pq and pfalse and falseq show "False" by (rule disjE)
     qed
     from npfalse have nnp: "¬¬P" by (rule notI)
     from nnp show p: "P" by (rule notnotD)
   qed
   from rp show "R ⟶ P" by (rule impI)
 qed
end


(*
  Title:    Preference_Profiles.thy
  Author:   Manuel Eberl, TU München

  Definition of (weak) preference profiles and functions for building
  and manipulating them
*)

section \<open>Preference Profiles\<close>

theory Preference_Profiles
imports
  Main
  Order_Predicates
  "~~/src/HOL/Library/Multiset"
  "~~/src/HOL/Library/Disjoint_Sets"
  Missing_Multiset
  Missing_Permutations
begin

text \<open>The type of preference profiles\<close>
type_synonym ('agent, 'alt) pref_profile = "'agent \<Rightarrow> 'alt relation"

locale preorder_family =
  fixes dom :: "'a set" and carrier :: "'b set" and R :: "'a \<Rightarrow> 'b relation"
  assumes nonempty_dom: "dom \<noteq> {}"
  assumes in_dom [simp]: "i \<in> dom \<Longrightarrow> preorder_on carrier (R i)"
  assumes not_in_dom [simp]: "i \<notin> dom \<Longrightarrow> \<not>R i x y"
begin

end

locale pref_profile_wf =
  fixes agents :: "'agent set" and alts :: "'alt set" and R :: "('agent, 'alt) pref_profile"
  assumes nonempty_agents [simp]: "agents \<noteq> {}" and nonempty_alts [simp]: "alts \<noteq> {}"
  assumes prefs_wf [simp]: "i \<in> agents \<Longrightarrow> finite_total_preorder_on alts (R i)"
  assumes prefs_undefined [simp]: "i \<notin> agents \<Longrightarrow> \<not>R i x y"
begin

lemma finite_alts [simp]: "finite alts"
proof -
  from nonempty_agents obtain i where "i \<in> agents" by blast
  then interpret finite_total_preorder_on alts "R i" by simp
  show ?thesis by fact
qed

lemma prefs_wf' [simp]:
  "i \<in> agents \<Longrightarrow> total_preorder_on alts (R i)" "i \<in> agents \<Longrightarrow> preorder_on alts (R i)"
  using prefs_wf[of i]
  by (simp_all add: finite_total_preorder_on_def total_preorder_on_def del: prefs_wf)

lemma not_outside:
  assumes "x \<preceq>[R i] y"
  shows   "i \<in> agents" "x \<in> alts" "y \<in> alts"
proof -
  from assms show "i \<in> agents" by (cases "i \<in> agents") auto
  then interpret preorder_on alts "R i" by simp
  from assms show "x \<in> alts" "y \<in> alts" by (simp_all add: not_outside)
qed

sublocale preorder_family agents alts R
  by (intro preorder_family.intro) simp_all

lemmas prefs_undefined' = not_in_dom'

lemma wf_update:
  assumes "i \<in> agents" "total_preorder_on alts Ri'"
  shows   "pref_profile_wf agents alts (R(i := Ri'))"
proof -
  interpret total_preorder_on alts Ri' by fact
  from finite_alts have "finite_total_preorder_on alts Ri'" by unfold_locales
  with assms show ?thesis
    by (auto intro!: pref_profile_wf.intro split: if_splits)
qed

lemma wf_permute_agents:
  assumes "\<sigma> permutes agents"
  shows   "pref_profile_wf agents alts (R \<circ> \<sigma>)"
  unfolding o_def using permutes_in_image[OF assms(1)]
  by (intro pref_profile_wf.intro prefs_wf) simp_all

lemma (in -) pref_profile_eqI:
  assumes "pref_profile_wf agents alts R1" "pref_profile_wf agents alts R2"
  assumes "\<And>x. x \<in> agents \<Longrightarrow> R1 x = R2 x"
  shows   "R1 = R2"
proof
  interpret R1: pref_profile_wf agents alts R1 by fact
  interpret R2: pref_profile_wf agents alts R2 by fact
  fix x show "R1 x = R2 x"
    by (cases "x \<in> agents"; intro ext) (simp_all add: assms(3))
qed

end

text \<open>
  Permutes a preference profile w.r.t. alternatives in the way described in the paper.
  This is needed for the definition of neutrality.
\<close>
definition permute_profile where
  "permute_profile \<sigma> R = (\<lambda>i x y. R i (inv \<sigma> x) (inv \<sigma> y))"

lemma permute_profile_map_relation:
  "permute_profile \<sigma> R = (\<lambda>i. map_relation (inv \<sigma>) (R i))"
  by (simp add: permute_profile_def map_relation_def)

lemma permute_profile_compose [simp]:
  "permute_profile \<sigma> (R \<circ> \<pi>) = permute_profile \<sigma> R \<circ> \<pi>"
  by (auto simp: fun_eq_iff permute_profile_def o_def)

lemma permute_profile_id [simp]: "permute_profile id R = R"
  by (simp add: permute_profile_def)

lemma permute_profile_o:
  assumes "bij f" "bij g"
  shows   "permute_profile f (permute_profile g R) = permute_profile (f \<circ> g) R"
  using assms by (simp add: permute_profile_def o_inv_distrib)

lemma (in pref_profile_wf) wf_permute_alts:
  assumes "\<sigma> permutes alts"
  shows   "pref_profile_wf agents alts (permute_profile \<sigma> R)"
proof (rule pref_profile_wf.intro)
  fix i assume "i \<in> agents"
  with assms interpret R: finite_total_preorder_on alts "R i" by simp

  from assms have [simp]: "inv \<sigma> x \<in> alts \<longleftrightarrow> x \<in> alts" for x
    by (simp add: permutes_in_image permutes_inv)

  show "finite_total_preorder_on alts (permute_profile \<sigma> R i)"
  proof
    fix x y assume "permute_profile \<sigma> R i x y"
    thus "x \<in> alts" "y \<in> alts"
      using R.not_outside[of "inv \<sigma> x" "inv \<sigma> y"]
      by (auto simp: permute_profile_def)
  next
    fix x y z assume "permute_profile \<sigma> R i x y" "permute_profile \<sigma> R i y z"
    thus "permute_profile \<sigma> R i x z"
      using R.trans[of "inv \<sigma> x" "inv \<sigma> y" "inv \<sigma> z"]
      by (simp_all add: permute_profile_def)
  qed (insert R.total R.refl R.finite_carrier, simp_all add: permute_profile_def)
qed (insert assms, simp_all add: permute_profile_def pref_profile_wf_def)

text \<open>
  This shows that the above definition is equivalent to that in the paper.
\<close>
lemma permute_profile_iff [simp]:
  fixes R :: "('agent, 'alt) pref_profile"
  assumes "\<sigma> permutes alts" "x \<in> alts" "y \<in> alts"
  defines "R' \<equiv> permute_profile \<sigma> R"
  shows   "\<sigma> x \<preceq>[R' i] \<sigma> y \<longleftrightarrow> x \<preceq>[R i] y"
  using assms by (simp add: permute_profile_def permutes_inverses)

subsection \<open>Pareto dominance\<close>

definition Pareto :: "('agent \<Rightarrow> 'alt relation) \<Rightarrow> 'alt relation" where
  "x \<preceq>[Pareto(R)] y \<longleftrightarrow> (\<exists>j. x \<preceq>[R j] x) \<and> (\<forall>i. x \<preceq>[R i] x \<longrightarrow> x \<preceq>[R i] y)"

text \<open>
  A Pareto loser is an alternative that is Pareto-dominated by some other alternative.
\<close>
definition pareto_losers :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt set" where
  "pareto_losers R = {x. \<exists>y. y \<succ>[Pareto(R)] x}"

lemma pareto_losersI [intro?, simp]: "y \<succ>[Pareto(R)] x \<Longrightarrow> x \<in> pareto_losers R"
  by (auto simp: pareto_losers_def)

context preorder_family
begin

lemma Pareto_iff:
  "x \<preceq>[Pareto(R)] y \<longleftrightarrow> (\<forall>i\<in>dom. x \<preceq>[R i] y)"
proof
  assume A: "x \<preceq>[Pareto(R)] y"
  then obtain j where j: "x \<preceq>[R j] x" by (auto simp: Pareto_def)
  hence j': "j \<in> dom" by (cases "j \<in> dom") auto
  then interpret preorder_on carrier "R j" by simp
  from j have "x \<in> carrier" by (auto simp: carrier_eq)
  with A preorder_on.refl[OF in_dom]
    show "(\<forall>i\<in>dom. x \<preceq>[R i] y)" by (auto simp: Pareto_def)
next
  assume A: "(\<forall>i\<in>dom. x \<preceq>[R i] y)"
  from nonempty_dom obtain j where j: "j \<in> dom" by blast
  then interpret preorder_on carrier "R j" by simp
  from j A have "x \<preceq>[R j] y" by simp
  hence "x \<preceq>[R j] x" using not_outside refl by blast
  with A show "x \<preceq>[Pareto(R)] y" by (auto simp: Pareto_def)
qed

lemma Pareto_strict_iff:
  "x \<prec>[Pareto(R)] y \<longleftrightarrow> (\<forall>i\<in>dom. x \<preceq>[R i] y) \<and> (\<exists>i\<in>dom. x \<prec>[R i] y)"
  by (auto simp: strongly_preferred_def Pareto_iff nonempty_dom)

lemma not_Pareto_strict_iff:
  "\<not>(x \<prec>[Pareto(R)] y) \<longleftrightarrow> ((\<exists>i\<in>dom. \<not> R i x y) \<or> (\<forall>i\<in>dom. R i x y \<and> R i y x))"
  unfolding Pareto_strict_iff by (auto simp: strongly_preferred_def)

lemma Pareto_strictI:
  assumes "\<And>i. i \<in> dom \<Longrightarrow> x \<preceq>[R i] y" "i \<in> dom" "x \<prec>[R i] y"
  shows   "x \<prec>[Pareto(R)] y"
  using assms by (auto simp: Pareto_strict_iff)

lemma Pareto_strictI':
  assumes "\<And>i. i \<in> dom \<Longrightarrow> x \<preceq>[R i] y" "i \<in> dom" "\<not>x \<succeq>[R i] y"
  shows   "x \<prec>[Pareto(R)] y"
proof -
  from assms interpret preorder_on carrier "R i" by simp
  from assms have "x \<prec>[R i] y" by (simp add: strongly_preferred_def)
  with assms show ?thesis by (auto simp: Pareto_strict_iff )
qed

sublocale Pareto: preorder_on carrier "Pareto(R)"
proof -
  have "preorder_on carrier (R i)" if "i \<in> dom" for i using that by simp_all
  note A = preorder_on.not_outside[OF this(1)] preorder_on.refl[OF this(1)]
           preorder_on.trans[OF this(1)]
  from nonempty_dom obtain i where i: "i \<in> dom" by blast
  show "preorder_on carrier (Pareto R)"
  proof
    fix x y assume "x \<preceq>[Pareto(R)] y"
    with A(1,2)[OF i] i show "x \<in> carrier" "y \<in> carrier" by (auto simp: Pareto_iff)
  qed (auto simp: Pareto_iff intro: A)
qed

lemma pareto_loser_in_alts:
  assumes "x \<in> pareto_losers R"
  shows   "x \<in> carrier"
proof -
  from assms obtain y i where "i \<in> dom" "x \<prec>[R i] y"
    by (auto simp: pareto_losers_def Pareto_strict_iff)
  then interpret preorder_on carrier "R i" by simp
  from \<open>x \<prec>[R i] y\<close> have "x \<preceq>[R i] y" by (simp add: strongly_preferred_def)
  thus "x \<in> carrier" using not_outside by simp
qed

lemma pareto_losersE:
  assumes "x \<in> pareto_losers R"
  obtains y where "y \<in> carrier" "y \<succ>[Pareto(R)] x"
proof -
  from assms obtain y where "y \<succ>[Pareto(R)] x" unfolding pareto_losers_def by blast
  moreover from this Pareto.not_outside[of x y] have "y \<in> carrier"
    by (simp add: strongly_preferred_def)
  ultimately show ?thesis using that by blast
qed

end

subsection \<open>Preferred alternatives\<close>

context pref_profile_wf
begin

lemma preferred_alts_subset_alts: "preferred_alts (R i) x \<subseteq> alts" (is ?A)
  and finite_preferred_alts [simp,intro!]: "finite (preferred_alts (R i) x)" (is ?B)
proof -
  have "?A \<and> ?B"
  proof (cases "i \<in> agents")
    assume "i \<in> agents"
    then interpret total_preorder_on alts "R i" by simp
    have "preferred_alts (R i) x \<subseteq> alts" using not_outside
      by (auto simp: preferred_alts_def)
    thus ?thesis by (auto dest: finite_subset)
  qed (auto simp: preferred_alts_def)
  thus ?A ?B by blast+
qed

lemma preferred_alts_altdef:
  "i \<in> agents \<Longrightarrow> preferred_alts (R i) x = {y\<in>alts. y \<succeq>[R i] x}"
  by (simp add: preorder_on.preferred_alts_altdef)

end

subsection \<open>Favourite alternatives\<close>

definition favorites :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt set" where
  "favorites R i = Max_wrt (R i)"

definition favorite :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt" where
  "favorite R i = the_elem (favorites R i)"

definition has_unique_favorites :: "('agent, 'alt) pref_profile \<Rightarrow> bool" where
  "has_unique_favorites R \<longleftrightarrow> (\<forall>i. favorites R i = {} \<or> is_singleton (favorites R i))"

context pref_profile_wf
begin

lemma favorites_altdef:
  "favorites R i = Max_wrt_among (R i) alts"
proof (cases "i \<in> agents")
  assume "i \<in> agents"
  with assms interpret total_preorder_on alts "R i" by simp
  show ?thesis
    by (simp add: favorites_def Max_wrt_total_preorder Max_wrt_among_total_preorder)
qed (insert assms, simp_all add: favorites_def Max_wrt_def Max_wrt_among_def pref_profile_wf_def)

lemma favorites_no_agent [simp]: "i \<notin> agents \<Longrightarrow> favorites R i = {}"
  by (auto simp: favorites_def Max_wrt_def Max_wrt_among_def)

lemma favorites_altdef':
  "favorites R i = {x\<in>alts. \<forall>y\<in>alts. x \<succeq>[R i] y}"
proof (cases "i \<in> agents")
  assume "i \<in> agents"
  then interpret finite_total_preorder_on alts "R i" by simp
  show ?thesis using Max_wrt_among_nonempty[of alts] Max_wrt_among_subset[of alts]
    by (auto simp: favorites_altdef Max_wrt_among_total_preorder)
qed simp_all

lemma favorites_subset_alts: "favorites R i \<subseteq> alts"
  using assms by (auto simp: favorites_altdef')

lemma finite_favorites [simp, intro]: "finite (favorites R i)"
  using favorites_subset_alts finite_alts  by (rule finite_subset)

lemma favorites_nonempty: "i \<in> agents \<Longrightarrow> favorites R i \<noteq> {}"
proof -
  assume "i \<in> agents"
  then interpret finite_total_preorder_on alts "R i" by simp
  show ?thesis unfolding favorites_def by (intro Max_wrt_nonempty) simp_all
qed

lemma favorites_permute:
  assumes i: "i \<in> agents" and perm: "\<sigma> permutes alts"
  shows   "favorites (permute_profile \<sigma> R) i = \<sigma> ` favorites R i"
proof -
  from i interpret finite_total_preorder_on alts "R i" by simp
  from perm show ?thesis
  unfolding favorites_def
    by (subst Max_wrt_map_relation_bij)
       (simp_all add: permute_profile_def map_relation_def permutes_bij)
qed

lemma has_unique_favorites_altdef:
  "has_unique_favorites R \<longleftrightarrow> (\<forall>i\<in>agents. is_singleton (favorites R i))"
proof safe
  fix i assume "has_unique_favorites R" "i \<in> agents"
  thus "is_singleton (favorites R i)" using favorites_nonempty[of i]
    by (auto simp: has_unique_favorites_def)
next
  assume "\<forall>i\<in>agents. is_singleton (favorites R i)"
  hence "is_singleton (favorites R i) \<or> favorites R i = {}" for i
    by (cases "i \<in> agents") (simp add: favorites_nonempty, simp add: favorites_altdef')
  thus "has_unique_favorites R" by (auto simp: has_unique_favorites_def)
qed

end

locale pref_profile_unique_favorites = pref_profile_wf agents alts R
  for agents :: "'agent set" and alts :: "'alt set" and R +
  assumes unique_favorites': "has_unique_favorites R"
begin

lemma unique_favorites: "i \<in> agents \<Longrightarrow> favorites R i = {favorite R i}"
  using unique_favorites'
  by (auto simp: favorite_def has_unique_favorites_altdef is_singleton_the_elem)

lemma favorite_in_alts: "i \<in> agents \<Longrightarrow> favorite R i \<in> alts"
  using favorites_subset_alts[of i] by (simp add: unique_favorites)

end

subsection \<open>Anonymous profiles\<close>

type_synonym ('agent, 'alt) apref_profile = "'alt set list multiset"

definition anonymous_profile :: "('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) apref_profile"
  where anonymous_profile_auxdef:
    "anonymous_profile R = image_mset (weak_ranking \<circ> R) (mset_set {i. R i \<noteq> (\<lambda>_ _. False)})"

lemma (in pref_profile_wf) agents_eq:
  "agents = {i. R i \<noteq> (\<lambda>_ _. False)}"
proof safe
  fix i assume i: "i \<in> agents" and Ri: "R i = (\<lambda>_ _. False)"
  from i interpret preorder_on alts "R i" by simp
  from carrier_eq Ri nonempty_alts show False by simp
next
  fix i assume "R i \<noteq> (\<lambda>_ _. False)"
  thus "i \<in> agents" using prefs_undefined'[of i] by (cases "i \<in> agents") auto
qed

lemma (in pref_profile_wf) anonymous_profile_def:
  "anonymous_profile R = image_mset (weak_ranking \<circ> R) (mset_set agents)"
  by (simp only: agents_eq anonymous_profile_auxdef)

lemma (in pref_profile_wf) anonymous_profile_permute:
  assumes "\<sigma> permutes alts"  "finite agents"
  shows   "anonymous_profile (permute_profile \<sigma> R) =
             image_mset (map (op ` \<sigma>)) (anonymous_profile R)"
proof -
  from assms(1) interpret R': pref_profile_wf agents alts "permute_profile \<sigma> R"
    by (rule wf_permute_alts)
  have "anonymous_profile (permute_profile \<sigma> R) =
          {#weak_ranking (map_relation (inv \<sigma>) (R x)). x \<in># mset_set agents#}"
    unfolding R'.anonymous_profile_def
    by (simp add:  multiset.map_comp permute_profile_map_relation o_def)
  also from assms have "\<dots> = {#map (op ` \<sigma>) (weak_ranking (R x)). x \<in># mset_set agents#}"
    by (intro image_mset_cong)
       (simp add: finite_total_preorder_on.weak_ranking_permute[of alts])
  also have "\<dots> = image_mset (map (op ` \<sigma>)) (anonymous_profile R)"
    by (simp add: anonymous_profile_def multiset.map_comp o_def)
  finally show ?thesis .
qed

lemma (in pref_profile_wf) anonymous_profile_update:
  assumes i:  "i \<in> agents" and fin [simp]: "finite agents" and "total_preorder_on alts Ri'"
  shows   "anonymous_profile (R(i := Ri')) =
             anonymous_profile R - {#weak_ranking (R i)#} + {#weak_ranking Ri'#}"
proof -
  from assms interpret R': pref_profile_wf agents alts "R(i := Ri')"
    by (simp add: finite_total_preorder_on_iff wf_update)
  have "anonymous_profile (R(i := Ri')) =
          {#weak_ranking (if x = i then Ri' else R x). x \<in># mset_set agents#}"
    by (simp add: R'.anonymous_profile_def o_def)
  also have "\<dots> = {#if x = i then weak_ranking Ri' else weak_ranking (R x). x \<in># mset_set agents#}"
    by (intro image_mset_cong) simp_all
  also have "\<dots> = {#weak_ranking Ri'. x \<in># mset_set {x \<in> agents. x = i}#} +
                    {#weak_ranking (R x). x \<in># mset_set {x \<in> agents. x \<noteq> i}#}"
    by (subst image_mset_If) ((subst filter_mset_mset_set, simp)+, rule refl)
  also from i have "{x \<in> agents. x = i} = {i}" by auto
  also have "{x \<in> agents. x \<noteq> i} = agents - {i}" by auto
  also have "{#weak_ranking Ri'. x \<in># mset_set {i}#} = {#weak_ranking Ri'#}" by simp
  also from i have "mset_set (agents - {i}) = mset_set agents - {#i#}"
    by (simp add: mset_set_Diff)
  also from i
    have "{#weak_ranking (R x). x \<in># \<dots>#} =
            {#weak_ranking (R x). x \<in># mset_set agents#} - {#weak_ranking (R i)#}"
      by (subst image_mset_Diff) (simp_all add: in_multiset_in_set mset_le_single)
  also have "{#weak_ranking Ri'#} + \<dots> =
               anonymous_profile R - {#weak_ranking (R i)#} + {#weak_ranking Ri'#}"
    by (simp add: anonymous_profile_def add_ac o_def)
  finally show ?thesis .
qed

subsection \<open>Preference profiles from lists\<close>

definition prefs_from_table :: "('agent \<times> 'alt set list) list \<Rightarrow> ('agent, 'alt) pref_profile" where
  "prefs_from_table xss = (\<lambda>i. case_option (\<lambda>_ _. False) of_weak_ranking (map_of xss i))"

definition prefs_from_table_wf where
  "prefs_from_table_wf agents alts xss \<longleftrightarrow> agents \<noteq> {} \<and> alts \<noteq> {} \<and> distinct (map fst xss) \<and>
       set (map fst xss) = agents \<and> (\<forall>xs\<in>set (map snd xss). (\<Union>set xs) = alts \<and>
       is_finite_weak_ranking xs)"

lemma prefs_from_table_wfI:
  assumes "agents \<noteq> {}" "alts \<noteq> {}" "distinct (map fst xss)"
  assumes "set (map fst xss) = agents"
  assumes "\<And>xs. xs \<in> set (map snd xss) \<Longrightarrow> (\<Union>set xs) = alts"
  assumes "\<And>xs. xs \<in> set (map snd xss) \<Longrightarrow> is_finite_weak_ranking xs"
  shows   "prefs_from_table_wf agents alts xss"
  using assms unfolding prefs_from_table_wf_def by auto

lemma prefs_from_table_wfD:
  assumes "prefs_from_table_wf agents alts xss"
  shows "agents \<noteq> {}" "alts \<noteq> {}" "distinct (map fst xss)"
    and "set (map fst xss) = agents"
    and "\<And>xs. xs \<in> set (map snd xss) \<Longrightarrow> (\<Union>set xs) = alts"
    and "\<And>xs. xs \<in> set (map snd xss) \<Longrightarrow> is_finite_weak_ranking xs"
  using assms unfolding prefs_from_table_wf_def by auto

lemma pref_profile_from_tableI:
  "prefs_from_table_wf agents alts xss \<Longrightarrow> pref_profile_wf agents alts (prefs_from_table xss)"
using assms
proof (intro pref_profile_wf.intro)
  assume wf: "prefs_from_table_wf agents alts xss"
  fix i assume i: "i \<in> agents"
  with wf have "i \<in> set (map fst xss)" by (simp add: prefs_from_table_wf_def)
  then obtain xs where xs: "xs \<in> set (map snd xss)" "prefs_from_table xss i = of_weak_ranking xs"
    by (cases "map_of xss i")
       (fastforce dest: map_of_SomeD simp: prefs_from_table_def map_of_eq_None_iff)+
  with wf show "finite_total_preorder_on alts (prefs_from_table xss i)"
    by (auto simp: prefs_from_table_wf_def intro!: finite_total_preorder_of_weak_ranking)
next
  assume wf: "prefs_from_table_wf agents alts xss"
  fix i x y assume i: "i \<notin> agents"
  with wf have "i \<notin> set (map fst xss)" by (simp add: prefs_from_table_wf_def)
  hence "map_of xss i = None" by (simp add: map_of_eq_None_iff)
  thus "\<not>prefs_from_table xss i x y" by (simp add: prefs_from_table_def)
qed (simp_all add: prefs_from_table_wf_def)

lemma prefs_from_table_eqI:
  assumes "distinct (map fst xs)" "distinct (map fst ys)" "set xs = set ys"
  shows   "prefs_from_table xs = prefs_from_table ys"
proof -
  from assms have "map_of xs = map_of ys" by (subst map_of_inject_set) simp_all
  thus ?thesis by (simp add: prefs_from_table_def)
qed

lemma prefs_from_table_undef:
  assumes "prefs_from_table_wf agents alts xss" "i \<notin> agents"
  shows   "prefs_from_table xss i = (\<lambda>_ _. False)"
proof -
  from assms have "i \<notin> fst ` set xss"
    by (simp add: prefs_from_table_wf_def)
  hence "map_of xss i = None" by (simp add: map_of_eq_None_iff)
  thus ?thesis by (simp add: prefs_from_table_def)
qed

lemma prefs_from_table_map_of:
  assumes "prefs_from_table_wf agents alts xss" "i \<in> agents"
  shows   "prefs_from_table xss i = of_weak_ranking (the (map_of xss i))"
  using assms
  by (auto simp: prefs_from_table_def map_of_eq_None_iff prefs_from_table_wf_def
           split: option.splits)

lemma prefs_from_table_update:
  fixes x xs
  assumes "i \<in> set (map fst xs)"
  defines "xs' \<equiv> map (\<lambda>(j,y). if j = i then (j, x) else (j, y)) xs"
  shows   "(prefs_from_table xs)(i := of_weak_ranking x) =
             prefs_from_table xs'" (is "?lhs = ?rhs")
proof
  have xs': "set (map fst xs') = set (map fst xs)" by (force simp: xs'_def)
  fix k
  consider "k = i" | "k \<notin> set (map fst xs)" | "k \<noteq> i" "k \<in> set (map fst xs)" by blast
  thus "?lhs k = ?rhs k"
  proof cases
    assume k: "k = i"
    moreover from k have "y = x" if "(i, y) \<in> set xs'" for y
      using that by (auto simp: xs'_def split: if_splits)
    ultimately show ?thesis using assms(1) k xs'
      by (auto simp add: prefs_from_table_def map_of_eq_None_iff
               dest!: map_of_SomeD split: option.splits)
  next
    assume k: "k \<notin> set (map fst xs)"
    with assms(1) have k': "k \<noteq> i" by auto
    with k xs' have "map_of xs k = None" "map_of xs' k = None"
      by (simp_all add: map_of_eq_None_iff)
    thus ?thesis by (simp add: prefs_from_table_def k')
  next
    assume k: "k \<noteq> i" "k \<in> set (map fst xs)"
    with k(1) have "map_of xs k = map_of xs' k" unfolding xs'_def
      by (induction xs) fastforce+
    with k show ?thesis by (simp add: prefs_from_table_def)
  qed
qed

lemma prefs_from_table_swap:
  "x \<noteq> y \<Longrightarrow> prefs_from_table ((x,x')#(y,y')#xs) = prefs_from_table ((y,y')#(x,x')#xs)"
  by (intro ext) (auto simp: prefs_from_table_def)

lemma permute_prefs_from_table:
  assumes "\<sigma> permutes fst ` set xs"
  shows   "prefs_from_table xs \<circ> \<sigma> = prefs_from_table (map (\<lambda>(x,y). (inv \<sigma> x, y)) xs)"
proof
  fix i
  have "(prefs_from_table xs \<circ> \<sigma>) i =
          (case map_of xs (\<sigma> i) of
             None \<Rightarrow> \<lambda>_ _. False
           | Some x \<Rightarrow> of_weak_ranking x)"
    by (simp add: prefs_from_table_def o_def)
  also have "map_of xs (\<sigma> i) = map_of (map (\<lambda>(x,y). (inv \<sigma> x, y)) xs) i"
    using map_of_permute[OF assms] by (simp add: o_def fun_eq_iff)
  finally show "(prefs_from_table xs \<circ> \<sigma>) i = prefs_from_table (map (\<lambda>(x,y). (inv \<sigma> x, y)) xs) i"
    by (simp only: prefs_from_table_def)
qed

lemma permute_profile_from_table:
  assumes wf: "prefs_from_table_wf agents alts xss"
  assumes perm: "\<sigma> permutes alts"
  shows   "permute_profile \<sigma> (prefs_from_table xss) =
             prefs_from_table (map (\<lambda>(x,y). (x, map (op ` \<sigma>) y)) xss)" (is "?f = ?g")
proof
  fix i
  have wf': "prefs_from_table_wf agents alts (map (\<lambda>(x, y). (x, map (op ` \<sigma>) y)) xss)"
  proof (intro prefs_from_table_wfI, goal_cases)
    case (5 xs)
    then obtain y where "y \<in> set xss" "xs = map (op ` \<sigma>) (snd y)"
      by (auto simp add: o_def case_prod_unfold)
    with assms show ?case
      by (simp add: image_Union [symmetric] prefs_from_table_wf_def permutes_image o_def case_prod_unfold)
  next
    case (6 xs)
    then obtain y where "y \<in> set xss" "xs = map (op ` \<sigma>) (snd y)"
      by (auto simp add: o_def case_prod_unfold)
    with assms show ?case
      by (auto simp: is_finite_weak_ranking_def is_weak_ranking_iff prefs_from_table_wf_def
            distinct_map permutes_inj_on inj_on_image intro!: disjoint_image)
  qed (insert assms, simp_all add: image_Union [symmetric] prefs_from_table_wf_def permutes_image o_def case_prod_unfold)
  show "?f i = ?g i"
  proof (cases "i \<in> agents")
    assume "i \<notin> agents"
    with assms wf' show ?thesis
      by (simp add: permute_profile_def prefs_from_table_undef)
  next
    assume i: "i \<in> agents"
    def xs \<equiv> "the (map_of xss i)"
    from i wf have xs: "map_of xss i = Some xs"
      by (cases "map_of xss i") (auto simp: prefs_from_table_wf_def xs_def)
    have xs_in_xss: "xs \<in> snd ` set xss"
      using xs by (force dest!: map_of_SomeD)
    with wf have set_xs: "\<Union>set xs = alts"
      by (simp add: prefs_from_table_wfD)

    from i have "prefs_from_table (map (\<lambda>(x,y). (x, map (op ` \<sigma>) y)) xss) i =
                   of_weak_ranking (the (map_of (map (\<lambda>(x,y). (x, map (op ` \<sigma>) y)) xss) i))"
      using wf' by (intro prefs_from_table_map_of) simp_all
    also have "\<dots> = of_weak_ranking (map (op ` \<sigma>) xs)"
      by (subst map_of_map) (simp add: xs)
    also have "\<dots> = (\<lambda>a b. of_weak_ranking xs (inv \<sigma> a) (inv \<sigma> b))"
      by (intro ext) (simp add: of_weak_ranking_permute map_relation_def set_xs perm)
    also have "\<dots> = permute_profile \<sigma> (prefs_from_table xss) i"
      by (simp add: prefs_from_table_def xs permute_profile_def)
    finally show ?thesis ..
  qed
qed

subsection \<open>Automatic evaluation of preference profiles\<close>

lemma eval_prefs_from_table [simp]:
  "prefs_from_table []i = (\<lambda>_ _. False)"
  "prefs_from_table ((i, y) # xs) i = of_weak_ranking y"
  "i \<noteq> j \<Longrightarrow> prefs_from_table ((j, y) # xs) i = prefs_from_table xs i"
  by (simp_all add: prefs_from_table_def)

lemma eval_of_weak_ranking [simp]:
  "a \<notin> \<Union>set xs \<Longrightarrow> \<not>of_weak_ranking xs a b"
  "b \<in> x \<Longrightarrow> a \<in> \<Union>set (x#xs) \<Longrightarrow> of_weak_ranking (x # xs) a b"
  "b \<notin> x \<Longrightarrow> of_weak_ranking (x # xs) a b \<longleftrightarrow> of_weak_ranking xs a b"
  by (induction xs) (simp_all add: of_weak_ranking_Cons)

lemma prefs_from_table_cong [cong]:
  assumes "prefs_from_table xs = prefs_from_table ys"
  shows   "prefs_from_table (x#xs) = prefs_from_table (x#ys)"
proof
  fix i
  show "prefs_from_table (x # xs) i = prefs_from_table (x # ys) i"
    using assms by (cases x, cases "i = fst x") simp_all
qed

definition of_weak_ranking_Collect_ge where
  "of_weak_ranking_Collect_ge xs x = {y. of_weak_ranking xs y x}"

lemma of_weak_ranking_Collect_ge_empty [simp]:
  "of_weak_ranking_Collect_ge [] x = {}"
  by (simp add: of_weak_ranking_Collect_ge_def)

lemma of_weak_ranking_Collect_ge_Cons [simp]:
  "y \<in> x \<Longrightarrow> of_weak_ranking_Collect_ge (x#xs) y = (\<Union>set (x#xs))"
  "y \<notin> x \<Longrightarrow> of_weak_ranking_Collect_ge (x#xs) y = of_weak_ranking_Collect_ge xs y"
  by (auto simp: of_weak_ranking_Cons of_weak_ranking_Collect_ge_def)

lemma of_weak_ranking_Collect_ge_Cons':
  "of_weak_ranking_Collect_ge (x#xs) = (\<lambda>y.
     (if y \<in> x then (\<Union>set (x#xs)) else of_weak_ranking_Collect_ge xs y))"
  by (auto simp: of_weak_ranking_Cons of_weak_ranking_Collect_ge_def fun_eq_iff)

(* TODO Move *)
lemma mset_set_set: "distinct xs \<Longrightarrow> mset_set (set xs) = mset xs"
  by (induction xs) (simp_all add: add_ac)

lemma image_mset_map_of:
  "distinct (map fst xs) \<Longrightarrow> {#the (map_of xs i). i \<in># mset (map fst xs)#} = mset (map snd xs)"
proof (induction xs)
  case (Cons x xs)
  have "{#the (map_of (x # xs) i). i \<in># mset (map fst (x # xs))#} =
          {#the (if i = fst x then Some (snd x) else map_of xs i).
             i \<in># mset (map fst xs)#} + {#snd x#}" (is "_ = ?A + _") by simp
  also from Cons.prems have "?A = {#the (map_of xs i). i :# mset (map fst xs)#}"
    by (cases x, intro image_mset_cong) (auto simp: in_multiset_in_set)
  also from Cons.prems have "\<dots> = mset (map snd xs)" by (intro Cons.IH) simp_all
  finally show ?case by simp
qed simp_all

lemma anonymise_prefs_from_table:
  assumes "prefs_from_table_wf agents alts xs"
  shows   "anonymous_profile (prefs_from_table xs) = mset (map snd xs)"
proof -
  from assms interpret pref_profile_wf agents alts "prefs_from_table xs"
    by (simp add: pref_profile_from_tableI)
  from assms have agents: "agents = fst ` set xs"
    by (simp add: prefs_from_table_wf_def)
  hence [simp]: "finite agents" by auto
  have "anonymous_profile (prefs_from_table xs) =
          {#weak_ranking (prefs_from_table xs x). x \<in># mset_set agents#}"
    by (simp add: o_def anonymous_profile_def)
  also from assms have "\<dots> = {#the (map_of xs i). i \<in># mset_set agents#}"
  proof (intro image_mset_cong)
    fix i assume i: "i \<in># mset_set agents"
    from i assms
      have "weak_ranking (prefs_from_table xs i) =
              weak_ranking (of_weak_ranking (the (map_of xs i))) "
      by (simp add: prefs_from_table_map_of)
    also from assms i have "\<dots> = the (map_of xs i)"
      by (intro weak_ranking_of_weak_ranking)
         (auto simp: prefs_from_table_wf_def)
    finally show "weak_ranking (prefs_from_table xs i) = the (map_of xs i)" .
  qed
  also from agents have "mset_set agents = mset_set (set (map fst xs))" by simp
  also from assms have "\<dots> = mset (map fst xs)"
    by (intro mset_set_set) (simp_all add: prefs_from_table_wf_def)
  also from assms have "{#the (map_of xs i). i \<in># mset (map fst xs)#} = mset (map snd xs)"
    by (intro image_mset_map_of) (simp_all add: prefs_from_table_wf_def)
  finally show ?thesis .
qed

lemma prefs_from_table_agent_permutation:
  assumes wf: "prefs_from_table_wf agents alts xs" "prefs_from_table_wf agents alts ys"
  assumes mset_eq: "mset (map snd xs) = mset (map snd ys)"
  obtains \<pi> where "\<pi> permutes agents" "prefs_from_table xs \<circ> \<pi> = prefs_from_table ys"
proof -
  from wf(1) have agents: "agents = set (map fst xs)"
    by (simp_all add: prefs_from_table_wf_def)
  from wf(2) have agents': "agents = set (map fst ys)"
    by (simp_all add: prefs_from_table_wf_def)
  from agents agents' wf(1) wf(2) have "mset (map fst xs) = mset (map fst ys)"
    by (subst set_eq_iff_mset_eq_distinct [symmetric]) (simp_all add: prefs_from_table_wfD)
  hence same_length: "length xs = length ys" by (auto dest: mset_eq_length)

  from \<open>mset (map fst xs) = mset (map fst ys)\<close>
    obtain g where g: "g permutes {..<length ys}" "permute_list g (map fst ys) = map fst xs"
    by (auto elim: mset_eq_permutation simp: same_length)

  from mset_eq g
    have "mset (map snd ys) = mset (permute_list g (map snd ys))" by simp
  with mset_eq obtain f
    where f: "f permutes {..<length xs}"
             "permute_list f (permute_list g (map snd ys)) = map snd xs"
    by (auto elim: mset_eq_permutation simp: same_length)
  from permutes_in_image[OF f(1)]
    have [simp]: "f x < length xs \<longleftrightarrow> x < length xs"
                 "f x < length ys \<longleftrightarrow> x < length ys" for x by (simp_all add: same_length)

  def idx \<equiv> "index (map fst xs)" and unidx \<equiv> "\<lambda>i. map fst xs ! i"
  from wf(1) have "bij_betw idx agents {0..<length xs}" unfolding idx_def
    by (intro bij_betw_index) (simp_all add: prefs_from_table_wf_def)
  hence bij_betw_idx: "bij_betw idx agents {..<length xs}" by (simp add: atLeast0LessThan)
  have [simp]: "idx x < length xs" if "x \<in> agents" for x
    using that by (simp add: idx_def agents)
  have [simp]: "unidx i \<in> agents" if "i < length xs" for i
    using that by (simp add: agents unidx_def)

  have unidx_idx: "unidx (idx x) = x" if x: "x \<in> agents" for x
    using x unfolding idx_def unidx_def using nth_index[of x "map fst xs"]
    by (simp add: agents set_map [symmetric] nth_map [symmetric] del: set_map)
  have idx_unidx: "idx (unidx i) = i" if i: "i < length xs" for i
    unfolding idx_def unidx_def using wf(1) index_nth_id[of "map fst xs" i] i
    by (simp add: prefs_from_table_wfD(3))

  def \<pi> \<equiv> "\<lambda>x. if x \<in> agents then (unidx \<circ> f \<circ> idx) x else x"
  def \<pi>' \<equiv> "\<lambda>x. if x \<in> agents then (unidx \<circ> inv f \<circ> idx) x else x"
  have "bij_betw (unidx \<circ> f \<circ> idx) agents agents" (is "?P") unfolding unidx_def
    by (rule bij_betw_trans bij_betw_idx permutes_imp_bij f g bij_betw_nth)+
       (insert wf(1) g, simp_all add: prefs_from_table_wf_def same_length)
  also have "?P \<longleftrightarrow> bij_betw \<pi> agents agents"
    by (intro bij_betw_cong) (simp add: \<pi>_def)
  finally have perm: "\<pi> permutes agents"
    by (intro bij_imp_permutes) (simp_all add: \<pi>_def)

  def h \<equiv> "g \<circ> f"
  from f g have h: "h permutes {..<length ys}" unfolding h_def
    by (intro permutes_compose) (simp_all add: same_length)

  have inv_\<pi>: "inv \<pi> = \<pi>'"
  proof (rule permutes_invI[OF perm])
    fix x assume "x \<in> agents"
    with f(1) show "\<pi>' (\<pi> x) = x"
      by (simp add: \<pi>_def \<pi>'_def idx_unidx unidx_idx inv_f_f permutes_inj)
  qed (simp add: \<pi>_def \<pi>'_def)
  with perm have inv_\<pi>': "inv \<pi>' = \<pi>" by (auto simp: inv_inv_eq permutes_bij)

  from wf h have "prefs_from_table ys = prefs_from_table (permute_list h ys)"
    by (intro prefs_from_table_eqI)
       (simp_all add: prefs_from_table_wfD permute_list_map [symmetric])
  also have "permute_list h ys = permute_list h (zip (map fst ys) (map snd ys))"
    by (simp add: zip_map_fst_snd)
  also from same_length f g
    have "permute_list h (zip (map fst ys) (map snd ys)) =
            zip (permute_list f (map fst xs)) (map snd xs)"
    by (subst permute_list_zip[OF h]) (simp_all add: h_def permute_list_compose)
  also {
    fix i assume i: "i < length xs"
    from i have "permute_list f (map fst xs) ! i = unidx (f i)"
      using permutes_in_image[OF f(1)] f(1)
      by (subst permute_list_nth) (simp_all add: same_length unidx_def)
    also from i have "\<dots> = \<pi> (unidx i)" by (simp add: \<pi>_def idx_unidx)
    also from i have "\<dots> = map \<pi> (map fst xs) ! i" by (simp add: unidx_def)
    finally have "permute_list f (map fst xs) ! i = map \<pi> (map fst xs) ! i" .
  }
  hence "permute_list f (map fst xs) = map \<pi> (map fst xs)"
    by (intro nth_equalityI) simp_all
  also have "zip (map \<pi> (map fst xs)) (map snd xs) = map (\<lambda>(x,y). (inv \<pi>' x, y)) xs"
    by (induction xs) (simp_all add: case_prod_unfold inv_\<pi>')
  also from permutes_inv[OF perm] inv_\<pi> have "prefs_from_table \<dots> = prefs_from_table xs \<circ> \<pi>'"
    by (intro permute_prefs_from_table [symmetric]) (simp_all add: agents)
  finally have "prefs_from_table xs \<circ> \<pi>' = prefs_from_table ys" ..
  with that[of \<pi>'] permutes_inv[OF perm] inv_\<pi> show ?thesis by auto
qed

lemma permute_list_distinct:
  assumes "f ` {..<length xs} \<subseteq> {..<length xs}" "distinct xs"
  shows   "permute_list f xs = map (\<lambda>x. xs ! f (index xs x)) xs"
  using assms by (intro nth_equalityI) (auto simp: index_nth_id permute_list_def)

lemma image_mset_eq_permutation:
  assumes "{#f x. x \<in># mset_set A#} = {#g x. x \<in># mset_set A#}" "finite A"
  obtains \<pi> where "\<pi> permutes A" "\<And>x. x \<in> A \<Longrightarrow> g (\<pi> x) = f x"
proof -
  from assms(2) obtain xs where xs: "A = set xs" "distinct xs"
    using finite_distinct_list by blast
  with assms have "mset (map f xs) = mset (map g xs)"
    by (simp add: mset_set_set mset_map)
  from mset_eq_permutation[OF this] obtain \<pi> where
    \<pi>: "\<pi> permutes {0..<length xs}" "permute_list \<pi> (map g xs) = map f xs"
    by (auto simp: atLeast0LessThan)
  def \<pi>' \<equiv> "\<lambda>x. if x \<in> A then (op ! xs \<circ> \<pi> \<circ> index xs) x else x"
  have "bij_betw (op ! xs \<circ> \<pi> \<circ> index xs) A A" (is "?P")
    by (rule bij_betw_trans bij_betw_index xs refl permutes_imp_bij \<pi> bij_betw_nth)+
       (simp_all add: atLeast0LessThan xs)
  also have "?P \<longleftrightarrow> bij_betw \<pi>' A A"
    by (intro bij_betw_cong) (simp_all add: \<pi>'_def)
  finally have "\<pi>' permutes A"
    by (rule bij_imp_permutes) (simp_all add: \<pi>'_def)
  moreover from \<pi> xs(1)[symmetric] xs(2) have "g (\<pi>' x) = f x" if "x \<in> A" for x
    by (simp add: permute_list_map permute_list_distinct
          permutes_image \<pi>'_def that atLeast0LessThan)
  ultimately show ?thesis by (rule that)
qed

lemma anonymous_profile_agent_permutation:
  assumes eq:  "anonymous_profile R1 = anonymous_profile R2"
  assumes wf:  "pref_profile_wf agents alts R1" "pref_profile_wf agents alts R2"
  assumes fin: "finite agents"
  obtains \<pi> where "\<pi> permutes agents" "R2 \<circ> \<pi> = R1"
proof -
  interpret R1: pref_profile_wf agents alts R1 by fact
  interpret R2: pref_profile_wf agents alts R2 by fact

  from eq have "{#weak_ranking (R1 x). x \<in># mset_set agents#} =
                  {#weak_ranking (R2 x). x \<in># mset_set agents#}"
    by (simp add: R1.anonymous_profile_def R2.anonymous_profile_def o_def)
  from image_mset_eq_permutation[OF this fin] guess \<pi> . note \<pi> = this
  from \<pi> have wf': "pref_profile_wf agents alts (R2 \<circ> \<pi>)"
    by (intro R2.wf_permute_agents)
  then interpret R2': pref_profile_wf agents alts "R2 \<circ> \<pi>" .
  have "R2 \<circ> \<pi> = R1"
  proof (intro pref_profile_eqI[OF wf' wf(1)])
    fix x assume x: "x \<in> agents"
    with \<pi> have "weak_ranking ((R2 o \<pi>) x) = weak_ranking (R1 x)" by simp
    with wf' wf(1) x show "(R2 \<circ> \<pi>) x = R1 x"
      by (intro weak_ranking_eqD[of alts] R2'.prefs_wf) simp_all
  qed
  from \<pi>(1) and this show ?thesis by (rule that)
qed

end