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

theory CompositionSeries
imports
  SimpleGroups
  MaximalNormalSubgroups
begin

section \<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" by (metis is_group subgroup.subgroup_of_subgroup)
  qed
  moreover have "i + 1 = length \<GG> \<Longrightarrow> subgroup (\<GG> ! i) G"
    using last notempty last_conv_nth by (metis add_diff_cancel_right' subgroup_self)
  ultimately show "i < length \<GG> \<Longrightarrow> subgroup (\<GG> ! i) G" by force
qed

text \<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 (metis H is_group iso iso_subgroup)
    hence "group (H\<lparr>carrier := \<Psi> ` \<GG> ! Suc i\<rparr>)" by (metis H subgroup.subgroup_is_group)
    ultimately have "restrict \<Psi> (\<GG> ! Suc i) ` \<GG> ! i \<lhd> H\<lparr>carrier := \<Psi> ` \<GG> ! Suc i\<rparr>"
      using is_group H iso_normal_subgroup by (auto 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 (G\<lparr>carrier := H\<rparr> Mod {\<one>}) = q" unfolding FactGroup_def using card_rcosets_triv order_def
      by (metis Hgroup.card_rcosets_triv HsubG finite monoid.cases_scheme monoid.select_convs(2) partial_object.select_convs(1) partial_object.update_convs(1) subgroup_finite)
    have "normal {\<one>} (G\<lparr>carrier := H\<rparr>)" by (metis Hgroup.is_group Hgroup.normal_inv_iff HsubG group.trivial_subgroup_is_normal is_group singleton_iff subgroup.one_closed subgroup.subgroup_of_subgroup)
    hence "group (G\<lparr>carrier := H\<rparr> Mod {\<one>})" by (metis normal.factorgroup_is_group)
    with orderH primeq have "simple_group (G\<lparr>carrier := H\<rparr> Mod {\<one>})" by (metis \<open>order (G\<lparr>carrier := H\<rparr> Mod {\<one>}) = q\<close> 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 (metis iso_order_closed)
    hence "order (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) = 1" unfolding order_def by auto
    hence "carrier (G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)) = {\<one>\<^bsub>G\<lparr>carrier := K \<inter> \<GG> ! (i + 1)\<rparr> Mod (K \<inter> \<GG> ! i)\<^esub>}"
      using group.order_one_triv_iff KGsiKGigroup by 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"
    moreover 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


(*
  File:      Multiset_Permutations.thy
  Author:    Manuel Eberl (TU München)

  Defines the set of permutations of a given multiset (or set), i.e. the set of all lists whose
  entries correspond to the multiset (resp. set).
*)
section \<open>Permutations of a Multiset\<close>
theory Multiset_Permutations
imports
  Complex_Main
  "~~/src/HOL/Library/Multiset"
  "~~/src/HOL/Library/Permutations"
begin

(* TODO Move *)
lemma mset_tl: "xs \<noteq> [] \<Longrightarrow> mset (tl xs) = mset xs - {#hd xs#}"
  by (cases xs) simp_all

lemma mset_set_image_inj:
  assumes "inj_on f A"
  shows   "mset_set (f ` A) = image_mset f (mset_set A)"
proof (cases "finite A")
  case True
  from this and assms show ?thesis by (induction A) auto
qed (insert assms, simp add: finite_image_iff)

lemma multiset_remove_induct [case_names empty remove]:
  assumes "P {#}" "\<And>A. A \<noteq> {#} \<Longrightarrow> (\<And>x. x \<in># A \<Longrightarrow> P (A - {#x#})) \<Longrightarrow> P A"
  shows   "P A"
proof (induction A rule: full_multiset_induct)
  case (less A)
  hence IH: "P B" if "B \<subset># A" for B using that by blast
  show ?case
  proof (cases "A = {#}")
    case True
    thus ?thesis by (simp add: assms)
  next
    case False
    hence "P (A - {#x#})" if "x \<in># A" for x
      using that by (intro IH) (simp add: mset_subset_diff_self)
    from False and this show "P A" by (rule assms)
  qed
qed

lemma map_list_bind: "map g (List.bind xs f) = List.bind xs (map g \<circ> f)"
  by (simp add: List.bind_def map_concat)

lemma mset_eq_mset_set_imp_distinct:
  "finite A \<Longrightarrow> mset_set A = mset xs \<Longrightarrow> distinct xs"
proof (induction xs arbitrary: A)
  case (Cons x xs A)
  from Cons.prems(2) have "x \<in># mset_set A" by simp
  with Cons.prems(1) have [simp]: "x \<in> A" by simp
  from Cons.prems have "x \<notin># mset_set (A - {x})" by simp
  also from Cons.prems have "mset_set (A - {x}) = mset_set A - {#x#}"
    by (subst mset_set_Diff) simp_all
  also have "mset_set A = mset (x#xs)" by (simp add: Cons.prems)
  also have "\<dots> - {#x#} = mset xs" by simp
  finally have [simp]: "x \<notin> set xs" by (simp add: in_multiset_in_set)
  from Cons.prems show ?case by (auto intro!: Cons.IH[of "A - {x}"] simp: mset_set_Diff)
qed simp_all
(* END TODO *)

subsection \<open>Permutations of a multiset\<close>

definition permutations_of_multiset :: "'a multiset \<Rightarrow> 'a list set" where
  "permutations_of_multiset A = {xs. mset xs = A}"

lemma permutations_of_multisetI: "mset xs = A \<Longrightarrow> xs \<in> permutations_of_multiset A"
  by (simp add: permutations_of_multiset_def)

lemma permutations_of_multisetD: "xs \<in> permutations_of_multiset A \<Longrightarrow> mset xs = A"
  by (simp add: permutations_of_multiset_def)

lemma permutations_of_multiset_Cons_iff:
  "x # xs \<in> permutations_of_multiset A \<longleftrightarrow> x \<in># A \<and> xs \<in> permutations_of_multiset (A - {#x#})"
  by (auto simp: permutations_of_multiset_def)

lemma permutations_of_multiset_empty [simp]: "permutations_of_multiset {#} = {[]}"
  unfolding permutations_of_multiset_def by simp

lemma permutations_of_multiset_nonempty:
  assumes nonempty: "A \<noteq> {#}"
  shows   "permutations_of_multiset A =
             (\<Union>x\<in>set_mset A. (op # x) ` permutations_of_multiset (A - {#x#}))" (is "_ = ?rhs")
proof safe
  fix xs assume "xs \<in> permutations_of_multiset A"
  hence mset_xs: "mset xs = A" by (simp add: permutations_of_multiset_def)
  hence "xs \<noteq> []" by (auto simp: nonempty)
  then obtain x xs' where xs: "xs = x # xs'" by (cases xs) simp_all
  with mset_xs have "x \<in> set_mset A" "xs' \<in> permutations_of_multiset (A - {#x#})"
    by (auto simp: permutations_of_multiset_def)
  with xs show "xs \<in> ?rhs" by auto
qed (auto simp: permutations_of_multiset_def)

lemma permutations_of_multiset_singleton [simp]: "permutations_of_multiset {#x#} = {[x]}"
  by (simp add: permutations_of_multiset_nonempty)

lemma permutations_of_multiset_doubleton:
  "permutations_of_multiset {#x,y#} = {[x,y], [y,x]}"
  by (simp add: permutations_of_multiset_nonempty insert_commute)

lemma rev_permutations_of_multiset [simp]:
  "rev ` permutations_of_multiset A = permutations_of_multiset A"
proof
  have "rev ` rev ` permutations_of_multiset A \<subseteq> rev ` permutations_of_multiset A"
    unfolding permutations_of_multiset_def by auto
  also have "rev ` rev ` permutations_of_multiset A = permutations_of_multiset A"
    by (simp add: image_image)
  finally show "permutations_of_multiset A \<subseteq> rev ` permutations_of_multiset A" .
next
  show "rev ` permutations_of_multiset A \<subseteq> permutations_of_multiset A"
    unfolding permutations_of_multiset_def by auto
qed

lemma length_finite_permutations_of_multiset:
  "xs \<in> permutations_of_multiset A \<Longrightarrow> length xs = size A"
  by (auto simp: permutations_of_multiset_def)

lemma permutations_of_multiset_lists: "permutations_of_multiset A \<subseteq> lists (set_mset A)"
  by (auto simp: permutations_of_multiset_def)

lemma finite_permutations_of_multiset [simp]: "finite (permutations_of_multiset A)"
proof (rule finite_subset)
  show "permutations_of_multiset A \<subseteq> {xs. set xs \<subseteq> set_mset A \<and> length xs = size A}"
    by (auto simp: permutations_of_multiset_def)
  show "finite {xs. set xs \<subseteq> set_mset A \<and> length xs = size A}"
    by (rule finite_lists_length_eq) simp_all
qed

lemma permutations_of_multiset_not_empty [simp]: "permutations_of_multiset A \<noteq> {}"
proof -
  from ex_mset[of A] guess xs ..
  thus ?thesis by (auto simp: permutations_of_multiset_def)
qed

lemma permutations_of_multiset_image:
  "permutations_of_multiset (image_mset f A) = map f ` permutations_of_multiset A"
proof safe
  fix xs assume A: "xs \<in> permutations_of_multiset (image_mset f A)"
  from ex_mset[of A] obtain ys where ys: "mset ys = A" ..
  with A have "mset xs = mset (map f ys)"
    by (simp add: permutations_of_multiset_def)
  from mset_eq_permutation[OF this] guess \<sigma> . note \<sigma> = this
  with ys have "xs = map f (permute_list \<sigma> ys)"
    by (simp add: permute_list_map)
  moreover from \<sigma> ys have "permute_list \<sigma> ys \<in> permutations_of_multiset A"
    by (simp add: permutations_of_multiset_def)
  ultimately show "xs \<in> map f ` permutations_of_multiset A" by blast
qed (auto simp: permutations_of_multiset_def)

subsection \<open>Cardinality of permutations\<close>

text \<open>
  In this section, we prove some basic facts about the number of permutations of a multiset.
\<close>

context
begin

private lemma multiset_prod_fact_insert:
  "(\<Prod>y\<in>set_mset (A+{#x#}). fact (count (A+{#x#}) y)) =
     (count A x + 1) * (\<Prod>y\<in>set_mset A. fact (count A y))"
proof -
  have "(\<Prod>y\<in>set_mset (A+{#x#}). fact (count (A+{#x#}) y)) =
          (\<Prod>y\<in>set_mset (A+{#x#}). (if y = x then count A x + 1 else 1) * fact (count A y))"
    by (intro prod.cong) simp_all
  also have "\<dots> = (count A x + 1) * (\<Prod>y\<in>set_mset (A+{#x#}). fact (count A y))"
    by (simp add: prod.distrib prod.delta)
  also have "(\<Prod>y\<in>set_mset (A+{#x#}). fact (count A y)) = (\<Prod>y\<in>set_mset A. fact (count A y))"
    by (intro prod.mono_neutral_right) (auto simp: not_in_iff)
  finally show ?thesis .
qed

private lemma multiset_prod_fact_remove:
  "x \<in># A \<Longrightarrow> (\<Prod>y\<in>set_mset A. fact (count A y)) =
                   count A x * (\<Prod>y\<in>set_mset (A-{#x#}). fact (count (A-{#x#}) y))"
  using multiset_prod_fact_insert[of "A - {#x#}" x] by simp

lemma card_permutations_of_multiset_aux:
  "card (permutations_of_multiset A) * (\<Prod>x\<in>set_mset A. fact (count A x)) = fact (size A)"
proof (induction A rule: multiset_remove_induct)
  case (remove A)
  have "card (permutations_of_multiset A) =
          card (\<Union>x\<in>set_mset A. op # x ` permutations_of_multiset (A - {#x#}))"
    by (simp add: permutations_of_multiset_nonempty remove.hyps)
  also have "\<dots> = (\<Sum>x\<in>set_mset A. card (permutations_of_multiset (A - {#x#})))"
    by (subst card_UN_disjoint) (auto simp: card_image)
  also have "\<dots> * (\<Prod>x\<in>set_mset A. fact (count A x)) =
               (\<Sum>x\<in>set_mset A. card (permutations_of_multiset (A - {#x#})) *
                 (\<Prod>y\<in>set_mset A. fact (count A y)))"
    by (subst sum_distrib_right) simp_all
  also have "\<dots> = (\<Sum>x\<in>set_mset A. count A x * fact (size A - 1))"
  proof (intro sum.cong refl)
    fix x assume x: "x \<in># A"
    have "card (permutations_of_multiset (A - {#x#})) * (\<Prod>y\<in>set_mset A. fact (count A y)) =
            count A x * (card (permutations_of_multiset (A - {#x#})) *
              (\<Prod>y\<in>set_mset (A - {#x#}). fact (count (A - {#x#}) y)))" (is "?lhs = _")
      by (subst multiset_prod_fact_remove[OF x]) simp_all
    also note remove.IH[OF x]
    also from x have "size (A - {#x#}) = size A - 1" by (simp add: size_Diff_submset)
    finally show "?lhs = count A x * fact (size A - 1)" .
  qed
  also have "(\<Sum>x\<in>set_mset A. count A x * fact (size A - 1)) =
                size A * fact (size A - 1)"
    by (simp add: sum_distrib_right size_multiset_overloaded_eq)
  also from remove.hyps have "\<dots> = fact (size A)"
    by (cases "size A") auto
  finally show ?case .
qed simp_all

theorem card_permutations_of_multiset:
  "card (permutations_of_multiset A) = fact (size A) div (\<Prod>x\<in>set_mset A. fact (count A x))"
  "(\<Prod>x\<in>set_mset A. fact (count A x) :: nat) dvd fact (size A)"
  by (simp_all add: card_permutations_of_multiset_aux[of A, symmetric])

lemma card_permutations_of_multiset_insert_aux:
  "card (permutations_of_multiset (A + {#x#})) * (count A x + 1) =
      (size A + 1) * card (permutations_of_multiset A)"
proof -
  note card_permutations_of_multiset_aux[of "A + {#x#}"]
  also have "fact (size (A + {#x#})) = (size A + 1) * fact (size A)" by simp
  also note multiset_prod_fact_insert[of A x]
  also note card_permutations_of_multiset_aux[of A, symmetric]
  finally have "card (permutations_of_multiset (A + {#x#})) * (count A x + 1) *
                    (\<Prod>y\<in>set_mset A. fact (count A y)) =
                (size A + 1) * card (permutations_of_multiset A) *
                    (\<Prod>x\<in>set_mset A. fact (count A x))" by (simp only: mult_ac)
  thus ?thesis by (subst (asm) mult_right_cancel) simp_all
qed

lemma card_permutations_of_multiset_remove_aux:
  assumes "x \<in># A"
  shows   "card (permutations_of_multiset A) * count A x =
             size A * card (permutations_of_multiset (A - {#x#}))"
proof -
  from assms have A: "A - {#x#} + {#x#} = A" by simp
  from assms have B: "size A = size (A - {#x#}) + 1"
    by (subst A [symmetric], subst size_union) simp
  show ?thesis
    using card_permutations_of_multiset_insert_aux[of "A - {#x#}" x, unfolded A] assms
    by (simp add: B)
qed

lemma real_card_permutations_of_multiset_remove:
  assumes "x \<in># A"
  shows   "real (card (permutations_of_multiset (A - {#x#}))) =
             real (card (permutations_of_multiset A) * count A x) / real (size A)"
  using assms by (subst card_permutations_of_multiset_remove_aux[OF assms]) auto

lemma real_card_permutations_of_multiset_remove':
  assumes "x \<in># A"
  shows   "real (card (permutations_of_multiset A)) =
             real (size A * card (permutations_of_multiset (A - {#x#}))) / real (count A x)"
  using assms by (subst card_permutations_of_multiset_remove_aux[OF assms, symmetric]) simp

end

subsection \<open>Permutations of a set\<close>

definition permutations_of_set :: "'a set \<Rightarrow> 'a list set" where
  "permutations_of_set A = {xs. set xs = A \<and> distinct xs}"

lemma permutations_of_set_altdef:
  "finite A \<Longrightarrow> permutations_of_set A = permutations_of_multiset (mset_set A)"
  by (auto simp add: permutations_of_set_def permutations_of_multiset_def mset_set_set
        in_multiset_in_set [symmetric] mset_eq_mset_set_imp_distinct)

lemma permutations_of_setI [intro]:
  assumes "set xs = A" "distinct xs"
  shows   "xs \<in> permutations_of_set A"
  using assms unfolding permutations_of_set_def by simp

lemma permutations_of_setD:
  assumes "xs \<in> permutations_of_set A"
  shows   "set xs = A" "distinct xs"
  using assms unfolding permutations_of_set_def by simp_all

lemma permutations_of_set_lists: "permutations_of_set A \<subseteq> lists A"
  unfolding permutations_of_set_def by auto

lemma permutations_of_set_empty [simp]: "permutations_of_set {} = {[]}"
  by (auto simp: permutations_of_set_def)

lemma UN_set_permutations_of_set [simp]:
  "finite A \<Longrightarrow> (\<Union>xs\<in>permutations_of_set A. set xs) = A"
  using finite_distinct_list by (auto simp: permutations_of_set_def)

lemma permutations_of_set_infinite:
  "\<not>finite A \<Longrightarrow> permutations_of_set A = {}"
  by (auto simp: permutations_of_set_def)

lemma permutations_of_set_nonempty:
  "A \<noteq> {} \<Longrightarrow> permutations_of_set A =
                  (\<Union>x\<in>A. (\<lambda>xs. x # xs) ` permutations_of_set (A - {x}))"
  by (cases "finite A")
     (simp_all add: permutations_of_multiset_nonempty mset_set_empty_iff mset_set_Diff
                    permutations_of_set_altdef permutations_of_set_infinite)

lemma permutations_of_set_singleton [simp]: "permutations_of_set {x} = {[x]}"
  by (subst permutations_of_set_nonempty) auto

lemma permutations_of_set_doubleton:
  "x \<noteq> y \<Longrightarrow> permutations_of_set {x,y} = {[x,y], [y,x]}"
  by (subst permutations_of_set_nonempty)
     (simp_all add: insert_Diff_if insert_commute)

lemma rev_permutations_of_set [simp]:
  "rev ` permutations_of_set A = permutations_of_set A"
  by (cases "finite A") (simp_all add: permutations_of_set_altdef permutations_of_set_infinite)

lemma length_finite_permutations_of_set:
  "xs \<in> permutations_of_set A \<Longrightarrow> length xs = card A"
  by (auto simp: permutations_of_set_def distinct_card)

lemma finite_permutations_of_set [simp]: "finite (permutations_of_set A)"
  by (cases "finite A") (simp_all add: permutations_of_set_infinite permutations_of_set_altdef)

lemma permutations_of_set_empty_iff [simp]:
  "permutations_of_set A = {} \<longleftrightarrow> \<not>finite A"
  unfolding permutations_of_set_def using finite_distinct_list[of A] by auto

lemma card_permutations_of_set [simp]:
  "finite A \<Longrightarrow> card (permutations_of_set A) = fact (card A)"
  by (simp add: permutations_of_set_altdef card_permutations_of_multiset del: One_nat_def)

lemma permutations_of_set_image_inj:
  assumes inj: "inj_on f A"
  shows   "permutations_of_set (f ` A) = map f ` permutations_of_set A"
  by (cases "finite A")
     (simp_all add: permutations_of_set_infinite permutations_of_set_altdef
                    permutations_of_multiset_image mset_set_image_inj inj finite_image_iff)

lemma permutations_of_set_image_permutes:
  "\<sigma> permutes A \<Longrightarrow> map \<sigma> ` permutations_of_set A = permutations_of_set A"
  by (subst permutations_of_set_image_inj [symmetric])
     (simp_all add: permutes_inj_on permutes_image)

subsection \<open>Code generation\<close>

text \<open>
  First, we give code an implementation for permutations of lists.
\<close>

declare length_remove1 [termination_simp]

fun permutations_of_list_impl where
  "permutations_of_list_impl xs = (if xs = [] then [[]] else
     List.bind (remdups xs) (\<lambda>x. map (op # x) (permutations_of_list_impl (remove1 x xs))))"

fun permutations_of_list_impl_aux where
  "permutations_of_list_impl_aux acc xs = (if xs = [] then [acc] else
     List.bind (remdups xs) (\<lambda>x. permutations_of_list_impl_aux (x#acc) (remove1 x xs)))"

declare permutations_of_list_impl_aux.simps [simp del]
declare permutations_of_list_impl.simps [simp del]

lemma permutations_of_list_impl_Nil [simp]:
  "permutations_of_list_impl [] = [[]]"
  by (simp add: permutations_of_list_impl.simps)

lemma permutations_of_list_impl_nonempty:
  "xs \<noteq> [] \<Longrightarrow> permutations_of_list_impl xs =
     List.bind (remdups xs) (\<lambda>x. map (op # x) (permutations_of_list_impl (remove1 x xs)))"
  by (subst permutations_of_list_impl.simps) simp_all

lemma set_permutations_of_list_impl:
  "set (permutations_of_list_impl xs) = permutations_of_multiset (mset xs)"
  by (induction xs rule: permutations_of_list_impl.induct)
     (subst permutations_of_list_impl.simps,
      simp_all add: permutations_of_multiset_nonempty set_list_bind)

lemma distinct_permutations_of_list_impl:
  "distinct (permutations_of_list_impl xs)"
  by (induction xs rule: permutations_of_list_impl.induct,
      subst permutations_of_list_impl.simps)
     (auto intro!: distinct_list_bind simp: distinct_map o_def disjoint_family_on_def)

lemma permutations_of_list_impl_aux_correct':
  "permutations_of_list_impl_aux acc xs =
     map (\<lambda>xs. rev xs @ acc) (permutations_of_list_impl xs)"
  by (induction acc xs rule: permutations_of_list_impl_aux.induct,
      subst permutations_of_list_impl_aux.simps, subst permutations_of_list_impl.simps)
     (auto simp: map_list_bind intro!: list_bind_cong)

lemma permutations_of_list_impl_aux_correct:
  "permutations_of_list_impl_aux [] xs = map rev (permutations_of_list_impl xs)"
  by (simp add: permutations_of_list_impl_aux_correct')

lemma distinct_permutations_of_list_impl_aux:
  "distinct (permutations_of_list_impl_aux acc xs)"
  by (simp add: permutations_of_list_impl_aux_correct' distinct_map
        distinct_permutations_of_list_impl inj_on_def)

lemma set_permutations_of_list_impl_aux:
  "set (permutations_of_list_impl_aux [] xs) = permutations_of_multiset (mset xs)"
  by (simp add: permutations_of_list_impl_aux_correct set_permutations_of_list_impl)

declare set_permutations_of_list_impl_aux [symmetric, code]

value [code] "permutations_of_multiset {#1,2,3,4::int#}"

text \<open>
  Now we turn to permutations of sets. We define an auxiliary version with an
  accumulator to avoid having to map over the results.
\<close>
function permutations_of_set_aux where
  "permutations_of_set_aux acc A =
     (if \<not>finite A then {} else if A = {} then {acc} else
        (\<Union>x\<in>A. permutations_of_set_aux (x#acc) (A - {x})))"
by auto
termination by (relation "Wellfounded.measure (card \<circ> snd)") (simp_all add: card_gt_0_iff)

lemma permutations_of_set_aux_altdef:
  "permutations_of_set_aux acc A = (\<lambda>xs. rev xs @ acc) ` permutations_of_set A"
proof (cases "finite A")
  assume "finite A"
  thus ?thesis
  proof (induction A arbitrary: acc rule: finite_psubset_induct)
    case (psubset A acc)
    show ?case
    proof (cases "A = {}")
      case False
      note [simp del] = permutations_of_set_aux.simps
      from psubset.hyps False
        have "permutations_of_set_aux acc A =
                (\<Union>y\<in>A. permutations_of_set_aux (y#acc) (A - {y}))"
        by (subst permutations_of_set_aux.simps) simp_all
      also have "\<dots> = (\<Union>y\<in>A. (\<lambda>xs. rev xs @ acc) ` (\<lambda>xs. y # xs) ` permutations_of_set (A - {y}))"
        by (intro SUP_cong refl, subst psubset) (auto simp: image_image)
      also from False have "\<dots> = (\<lambda>xs. rev xs @ acc) ` permutations_of_set A"
        by (subst (2) permutations_of_set_nonempty) (simp_all add: image_UN)
      finally show ?thesis .
    qed simp_all
  qed
qed (simp_all add: permutations_of_set_infinite)

declare permutations_of_set_aux.simps [simp del]

lemma permutations_of_set_aux_correct:
  "permutations_of_set_aux [] A = permutations_of_set A"
  by (simp add: permutations_of_set_aux_altdef)

text \<open>
  In another refinement step, we define a version on lists.
\<close>
declare length_remove1 [termination_simp]

fun permutations_of_set_aux_list where
  "permutations_of_set_aux_list acc xs =
     (if xs = [] then [acc] else
        List.bind xs (\<lambda>x. permutations_of_set_aux_list (x#acc) (List.remove1 x xs)))"

definition permutations_of_set_list where
  "permutations_of_set_list xs = permutations_of_set_aux_list [] xs"

declare permutations_of_set_aux_list.simps [simp del]

lemma permutations_of_set_aux_list_refine:
  assumes "distinct xs"
  shows   "set (permutations_of_set_aux_list acc xs) = permutations_of_set_aux acc (set xs)"
  using assms
  by (induction acc xs rule: permutations_of_set_aux_list.induct)
     (subst permutations_of_set_aux_list.simps,
      subst permutations_of_set_aux.simps,
      simp_all add: set_list_bind cong: SUP_cong)

text \<open>
  The permutation lists contain no duplicates if the inputs contain no duplicates.
  Therefore, these functions can easily be used when working with a representation of
  sets by distinct lists.
  The same approach should generalise to any kind of set implementation that supports
  a monadic bind operation, and since the results are disjoint, merging should be cheap.
\<close>
lemma distinct_permutations_of_set_aux_list:
  "distinct xs \<Longrightarrow> distinct (permutations_of_set_aux_list acc xs)"
  by (induction acc xs rule: permutations_of_set_aux_list.induct)
     (subst permutations_of_set_aux_list.simps,
      auto intro!: distinct_list_bind simp: disjoint_family_on_def
         permutations_of_set_aux_list_refine permutations_of_set_aux_altdef)

lemma distinct_permutations_of_set_list:
    "distinct xs \<Longrightarrow> distinct (permutations_of_set_list xs)"
  by (simp add: permutations_of_set_list_def distinct_permutations_of_set_aux_list)

lemma permutations_of_list:
    "permutations_of_set (set xs) = set (permutations_of_set_list (remdups xs))"
  by (simp add: permutations_of_set_aux_correct [symmetric]
        permutations_of_set_aux_list_refine permutations_of_set_list_def)

lemma permutations_of_list_code [code]:
  "permutations_of_set (set xs) = set (permutations_of_set_list (remdups xs))"
  "permutations_of_set (List.coset xs) =
     Code.abort (STR ''Permutation of set complement not supported'')
       (\<lambda>_. permutations_of_set (List.coset xs))"
  by (simp_all add: permutations_of_list)

value [code] "permutations_of_set (set ''abcd'')"

end


header "Arrays in SPARK vs Lists in Isabelle"
theory Global_User
imports Main
begin

subsection "Functions vs Lists"

text{* Arrays defined in SPARK are represented as functions in
Isabelle. In the specification, it is more convenient to use
lists. Therefore it is a common task to prove equivalences like
$\forall i \leq \mathsf{length}\ l.\ l\ !\ i = f\ i$, where $l$ is the
list specified in Isabelle and $f$ the function corresponding to the
array defined in SPARK. *}

text{* Constructing a function from a list makes things easier for the
simplifier, otherwise the definition of the list would need to be
unfolded $(\mathsf{length}\ l)$ times what yields to
efficiency-problems.*}

primrec list_to_fun where
  "list_to_fun [] _ (f::int \<Rightarrow> int) = f"
| "list_to_fun (a # xs) i f = (list_to_fun xs (i + 1) f) (i := (int a))"

lemma nth_list_to_fun_eq_aux:
  assumes "i_0 <= i" and "i < length l + i_0"
  shows "int (l ! (i - i_0)) = (list_to_fun l (int i_0) f) (int i)"
  using assms
proof (induct l arbitrary: i i_0)
  case Nil
  thus ?case by simp
next
  case (Cons a xs)
  moreover have aux: "1 + int i_0 = int i_0 + 1" by simp
  ultimately show ?case by (simp add: nth_Cons' aux)
qed

lemma nth_list_to_fun_eq:
  assumes "0 <= i" and "i < length l"
  shows "int (l ! i) = (list_to_fun l 0 f) (int i)"
proof -
  have "int (l ! (i - 0)) =
    (list_to_fun l (int 0) f) (int i)"
    by (rule nth_list_to_fun_eq_aux) (simp_all add: assms)
  thus ?thesis by simp
qed

text {* A tail-recursive definition makes it even more efficient. *}

primrec list_to_fun_eff where
  "list_to_fun_eff [] _ (f::int \<Rightarrow> int) = f"
| "list_to_fun_eff (a # xs) i f = list_to_fun_eff xs (i + 1) (f(i := (int a)))"

lemma list_to_fun_id:
  assumes "i_0 > i"
  shows "list_to_fun_eff l (int i_0) f (int i) = f (int i)"
using assms
proof (induct l arbitrary: i_0 f)
  case Nil
  thus ?case by simp
next
  case (Cons a xs)
  have I: "int i_0 + 1 = int (i_0 + 1)" by simp
  from Cons(2) have L: "i < i_0 + 1" by simp
  with Cons have
    "list_to_fun_eff xs (int i_0 + 1) (f(int i_0 := int a)) (int i) = f (int i)"
    unfolding I Cons(1)[OF L] by simp
  thus ?case by simp
qed

lemma nth_list_to_fun_eff_eq_aux:
  assumes "i_0 <= i" and "i < length l + i_0"
  shows "int (l ! (i - i_0)) = (list_to_fun_eff l (int i_0) f) (int i)"
  using assms
proof (induct l arbitrary: i f i_0)
  case Nil
  thus ?case by simp
next
  case (Cons a xs)
  have I: "int i_0 + 1 = int (i_0 + 1)" by simp
  {
    assume "i = i_0"
    moreover
    have "i_0 + 1 > i_0" by simp
    have
      "int a = list_to_fun_eff xs (int i_0 + 1) (f(int i_0 := int a)) (int i_0)"
      unfolding I list_to_fun_id[OF `i_0 + 1 > i_0`] by simp
    ultimately have ?case by (simp add: nth_Cons')
  }
  moreover
  {
    assume "i \<noteq> i_0"
    moreover
    hence H: "i_0 + 1 <= i" using Cons by simp
    have H': "i < length xs + (i_0 + 1)" using Cons (3) by simp
    have "int (xs ! (i - Suc i_0)) =
      list_to_fun_eff xs (int i_0 + 1) (f(int i_0 := int a)) (int i)"
      unfolding I Cons(1)[OF H H', symmetric] by simp
    ultimately have ?case using Cons(2) by (simp add: nth_Cons')
  }
  ultimately show ?case by blast
qed

lemma nth_list_to_fun_eff_eq:
  assumes "0 <= i" and "i < length l"
  shows "int (l ! i) = (list_to_fun_eff l 0 f) (int i)"
proof -
  have "int (l ! (i - 0)) =
    (list_to_fun_eff l (int 0) f) (int i)"
    by (rule nth_list_to_fun_eff_eq_aux) (simp_all add: assms)
  thus ?thesis by simp
qed

subsection{* Maximum Element of Lists *}

text{* The following lemmas help the simplifier to prove properties
about maximal elements of a list. It is easier to calculate the
maximum element of a list in an efficient way (using fold) and prove
the correctness of this calculation. *}

lemma fold_max_leq:
  fixes i j :: nat
  assumes "i <= j"
  shows "foldl max i l <= foldl max j l"
using assms
by (induct l arbitrary: i j) simp_all

lemma fold_max_lower:
  fixes i :: nat
  shows "i <= foldl max i l"
proof (induct l arbitrary: i)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (cases "i <= x")
    case True
    moreover have "x <= foldl max x xs" using Cons .
    ultimately show ?thesis by simp
  next
    case False
    thus ?thesis using Cons by (simp add: max_def)
  qed
qed

lemma list_max:
  fixes l::"nat list"
  fixes i::"nat"
  assumes "0 <= l ! i"
  assumes "0 <= i"
  assumes "i < length l"
  shows "l ! i <= foldl max 0 l"
  using assms
proof (induct l arbitrary: i)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (cases i)
    case (Suc j)
    note Cons(1)
    moreover have "0 <= xs ! (i - 1)" using Suc Cons by simp
    moreover have "0 <= i - 1" using Cons by simp
    moreover have "i - 1 < length xs" using Suc Cons by simp
    ultimately
    have "xs ! (i - 1) <= foldl max 0 xs" .
    moreover have "(x#xs) ! i = xs ! (i - 1)"
      using Suc Cons by simp
    moreover have "foldl max 0 xs <= foldl max (max 0 x) xs"
      by (rule fold_max_leq) simp
    ultimately
    show ?thesis by simp
  next
    case 0
    moreover have H: "(max 0 x) \<le> foldl max (max 0 x) xs" using fold_max_lower
      by simp
    ultimately show ?thesis
      by (cases "0 <= x") simp_all
  qed
qed

lemma list_max_int:
  assumes "l ! nat j \<le> foldl max 0 l"
  assumes "foldl max 0 l = nat U"
  assumes "0 <= j"
  assumes "0 <= U"
  shows "int (l ! nat j) \<le> U"
  using assms by simp

end


chapter {* R2: Razonamiento sobre programas en Isabelle/HOL *}

theory R2_Razonamiento_automatico_sobre_programas
imports Main
begin

declare [[names_short]]

text {* ---------------------------------------------------------------
  Ejercicio 1.1. Definir la función
     sumaImpares :: nat \<Rightarrow> nat
  tal que (sumaImpares n) es la suma de los n primeros números
  impares. Por ejemplo,
     sumaImpares 5  =  25
  ------------------------------------------------------------------ *}

fun sumaImpares :: "nat \<Rightarrow> nat" where
  "sumaImpares 0 = 0" |
  "sumaImpares (Suc n) = 2*(Suc n) - 1 + sumaImpares n"

text {* ---------------------------------------------------------------
  Ejercicio 1.2. Demostrar que
     sumaImpares n = n*n
  ------------------------------------------------------------------- *}

lemma "sumaImpares n = n*n"
  by (induct n) simp_all

text {* ---------------------------------------------------------------
  Ejercicio 2.1. Definir la función
     sumaPotenciasDeDosMasUno :: nat \<Rightarrow> nat
  tal que
     (sumaPotenciasDeDosMasUno n) = 1 + 2^0 + 2^1 + 2^2 + ... + 2^n.
  Por ejemplo,
     sumaPotenciasDeDosMasUno 3  =  16
  ------------------------------------------------------------------ *}

fun sumaPotenciasDeDosMasUno :: "nat \<Rightarrow> nat" where
  "sumaPotenciasDeDosMasUno 0 = 1 + 1" |
  "sumaPotenciasDeDosMasUno (Suc n) = 2^(Suc n) + sumaPotenciasDeDosMasUno n"

text {* ---------------------------------------------------------------
  Ejercicio 2.2. Demostrar que
     sumaPotenciasDeDosMasUno n = 2^(n+1)
  ------------------------------------------------------------------- *}

lemma "sumaPotenciasDeDosMasUno n = 2^(n+1)"
  by (induct n) simp_all

text {* ---------------------------------------------------------------
  Ejercicio 3.1. Definir la función
     copia :: nat \<Rightarrow> 'a \<Rightarrow> 'a list
  tal que (copia n x) es la lista formado por n copias del elemento
  x. Por ejemplo,
     copia 3 x = [x,x,x]
  ------------------------------------------------------------------ *}

fun copia :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "copia 0 x = []" |
  "copia (Suc n) x = x # copia n x"

text {* ---------------------------------------------------------------
  Ejercicio 3.2. Definir la función
     todos :: ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool
  tal que (todos p xs) se verifica si todos los elementos de xs cumplen
  la propiedad p. Por ejemplo,
     todos (\<lambda>x. x>(1::nat)) [2,6,4] = True
     todos (\<lambda>x. x>(2::nat)) [2,6,4] = False
  Nota: La conjunción se representa por \<and>
  ----------------------------------------------------------------- *}

fun todos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "todos p [] = True" |
  "todos p (x#xs) = (p x \<and> todos p xs)"

text {* ---------------------------------------------------------------
  Ejercicio 3.3. Demostrar que todos los elementos de (copia n x) son
  iguales a x.
  ------------------------------------------------------------------- *}

lemma "todos (\<lambda>y. y=x) (copia n x)"
  by (induct n) simp_all

text {* ---------------------------------------------------------------
  Ejercicio 4.1. Definir, recursivamente y sin usar (@), la función
     amplia :: 'a list \<Rightarrow> 'a \<Rightarrow> 'a list
  tal que (amplia xs y) es la lista obtenida añadiendo el elemento y al
  final de la lista xs. Por ejemplo,
     amplia [d,a] t = [d,a,t]
  ------------------------------------------------------------------ *}

fun amplia :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "amplia [] y = [y]" |
  "amplia (x#xs) y = x#amplia xs y"

value "amplia [a,b] c"

text {* ---------------------------------------------------------------
  Ejercicio 4.2. Demostrar que
     amplia xs y = xs @ [y]
  ------------------------------------------------------------------- *}

lemma "amplia xs y = xs @ [y]"
  by (induct xs) simp_all

end


theory Chapter4
imports "~~/src/HOL/IMP/ASM"
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

text{*
\section*{Chapter 4}

\exercise
Start from the data type of binary trees defined earlier:
*}

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

text{*
An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
@{text l} and @{text r} are ordered
and all values in @{text l} are @{text "< i"}
and all values in @{text r} are @{text "> i"}.
Define a function that returns the elements in a tree and one
the tests if a tree is ordered:
*}

fun set :: "'a tree \<Rightarrow> 'a set"
  where
    "set Tip = {}"
  | "set (Node l i r) = set l \<union> {i} \<union> set r"

fun ord :: "int tree \<Rightarrow> bool"
  where
    "ord Tip = True"
  | "ord (Node l i r) = (ord l \<and> ord r \<and> (\<forall> x \<in> set l. x < i) \<and> (\<forall> x \<in> set r. x > i))"

text{* Hint: use quantifiers.

Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
while maintaining the order of the tree. If the element is already in the tree, the
same tree should be returned.
*}

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"
  where
    "ins n Tip = (Node Tip n Tip)"
  | "ins n (Node l i r) =
      (if n = i then (Node l i r)
       else if n < i then (Node (ins n l) i r)
       else (Node l i (ins n r)))"

text{* Prove correctness of @{const ins}: *}

lemma set_ins: "set(ins x t) = {x} \<union> set t"
  apply(induction t arbitrary: x)
   apply(auto)
  done

theorem ord_ins: "ord t \<Longrightarrow> ord(ins i t)"
  apply(induction t arbitrary: i)
   apply(auto simp add: set_ins)
  done

text{*
\endexercise

\exercise
Formalize the following definition of palindromes
\begin{itemize}
\item The empty list and a singleton list are palindromes.
\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
\end{itemize}
as an inductive predicate
*}

inductive palindrome :: "'a list \<Rightarrow> bool" where
(* your definition/proof here *)

text {* and prove *}

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
(* your definition/proof here *)

text{*
\endexercise

\exercise
We could also have defined @{const star} as follows:
*}

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

text{*
The single @{text r} step is performer after rather than before the @{text star'}
steps. Prove
*}

lemma "star' r x y \<Longrightarrow> star r x y"
(* your definition/proof here *)

lemma "star r x y \<Longrightarrow> star' r x y"
(* your definition/proof here *)

text{*
You may need lemmas. Note that rule induction fails
if the assumption about the inductive predicate
is not the first assumption.
\endexercise

\exercise\label{exe:iter}
Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
all @{prop"i < n"}:
*}

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
(* your definition/proof here *)

text{*
Correct and prove the following claim:
*}

lemma "star r x y \<Longrightarrow> iter r n x y"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:cfg}
A context-free grammar can be seen as an inductive definition where each
nonterminal $A$ is an inductively defined predicate on lists of terminal
symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
For example, the production $S \to aSb$ can be viewed as the implication
@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
i.e., elements of some alphabet. The alphabet can be defined as a datatype:
*}

datatype alpha = a | b

text{*
If you think of @{const a} and @{const b} as ``@{text "("}'' and  ``@{text ")"}'',
the following two grammars both generate strings of balanced parentheses
(where $\varepsilon$ is the empty word):
\[
\begin{array}{r@ {\quad}c@ {\quad}l}
S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
T &\to& \varepsilon \quad\mid\quad TaTb
\end{array}
\]
Define them as inductive predicates and prove their equivalence:
*}

inductive S :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

inductive T :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

lemma TS: "T w \<Longrightarrow> S w"
(* your definition/proof here *)

lemma ST: "S w \<Longrightarrow> T w"
(* your definition/proof here *)

corollary SeqT: "S w \<longleftrightarrow> T w"
(* your definition/proof here *)

text{*
\endexercise
*}
(* your definition/proof here *)
text{*
\exercise
In Chapter 3 we defined a recursive evaluation function
@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
Define an inductive evaluation predicate and prove that it agrees with
the recursive function:
*}

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
(* your definition/proof here *)

lemma aval_rel_aval: "aval_rel a s v \<Longrightarrow> aval a s = v"
(* your definition/proof here *)

lemma aval_aval_rel: "aval a s = v \<Longrightarrow> aval_rel a s v"
(* your definition/proof here *)

corollary "aval_rel a s v \<longleftrightarrow> aval a s = v"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Consider the stack machine from Chapter~3
and recall the concept of \concept{stack underflow}
from Exercise~\ref{exe:stack-underflow}.
Define an inductive predicate
*}

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
(* your definition/proof here *)

text{*
such that @{text "ok n is n'"} means that with any initial stack of length
@{text n} the instructions @{text "is"} can be executed
without stack underflow and that the final stack has length @{text n'}.

Using the introduction rules for @{const ok},
prove the following special cases: *}

lemma "ok 0 [LOAD x] (Suc 0)"
(* your definition/proof here *)

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
(* your definition/proof here *)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
(* your definition/proof here *)

text {* Prove that @{text ok} correctly computes the final stack size: *}

lemma "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
(* your definition/proof here *)

text {*
Prove that instruction sequences generated by @{text comp}
cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
some suitable value of @{text "?"}.
\endexercise
*}

end


(*  Title:      CCL/Trancl.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section \<open>Transitive closure of a relation\<close>

theory Trancl
imports CCL
begin

definition trans :: "i set \<Rightarrow> o"  (*transitivity predicate*)
  where "trans(r) == (ALL x y z. <x,y>:r \<longrightarrow> <y,z>:r \<longrightarrow> <x,z>:r)"

definition id :: "i set"  (*the identity relation*)
  where "id == {p. EX x. p = <x,x>}"

definition relcomp :: "[i set,i set] \<Rightarrow> i set"  (infixr "O" 60)  (*composition of relations*)
  where "r O s == {xz. EX x y z. xz = <x,z> \<and> <x,y>:s \<and> <y,z>:r}"

definition rtrancl :: "i set \<Rightarrow> i set"  ("(_^*)" [100] 100)
  where "r^* == lfp(\<lambda>s. id Un (r O s))"

definition trancl :: "i set \<Rightarrow> i set"  ("(_^+)" [100] 100)
  where "r^+ == r O rtrancl(r)"

subsection \<open>Natural deduction for \<open>trans(r)\<close>\<close>

lemma transI: "(\<And>x y z. \<lbrakk><x,y>:r; <y,z>:r\<rbrakk> \<Longrightarrow> <x,z>:r) \<Longrightarrow> trans(r)"
  unfolding trans_def by blast

lemma transD: "\<lbrakk>trans(r); <a,b>:r; <b,c>:r\<rbrakk> \<Longrightarrow> <a,c>:r"
  unfolding trans_def by blast

subsection \<open>Identity relation\<close>

lemma idI: "<a,a> : id"
  apply (unfold id_def)
  apply (rule CollectI)
  apply (rule exI)
  apply (rule refl)
  done

lemma idE: "\<lbrakk>p: id;  \<And>x. p = <x,x> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  apply (unfold id_def)
  apply (erule CollectE)
  apply blast
  done

subsection \<open>Composition of two relations\<close>

lemma compI: "\<lbrakk><a,b>:s; <b,c>:r\<rbrakk> \<Longrightarrow> <a,c> : r O s"
  unfolding relcomp_def by blast

(*proof requires higher-level assumptions or a delaying of hyp_subst_tac*)
lemma compE: "\<lbrakk>xz : r O s; \<And>x y z. \<lbrakk>xz = <x,z>; <x,y>:s; <y,z>:r\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  unfolding relcomp_def by blast

lemma compEpair: "\<lbrakk><a,c> : r O s; \<And>y. \<lbrakk><a,y>:s; <y,c>:r\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  apply (erule compE)
  apply (simp add: pair_inject)
  done

lemmas [intro] = compI idI
  and [elim] = compE idE

lemma comp_mono: "\<lbrakk>r'<=r; s'<=s\<rbrakk> \<Longrightarrow> (r' O s') <= (r O s)"
  by blast

subsection \<open>The relation rtrancl\<close>

lemma rtrancl_fun_mono: "mono(\<lambda>s. id Un (r O s))"
  apply (rule monoI)
  apply (rule monoI subset_refl comp_mono Un_mono)+
  apply assumption
  done

lemma rtrancl_unfold: "r^* = id Un (r O r^*)"
  by (rule rtrancl_fun_mono [THEN rtrancl_def [THEN def_lfp_Tarski]])

(*Reflexivity of rtrancl*)
lemma rtrancl_refl: "<a,a> : r^*"
  apply (subst rtrancl_unfold)
  apply blast
  done

(*Closure under composition with r*)
lemma rtrancl_into_rtrancl: "\<lbrakk><a,b> : r^*; <b,c> : r\<rbrakk> \<Longrightarrow> <a,c> : r^*"
  apply (subst rtrancl_unfold)
  apply blast
  done

(*rtrancl of r contains r*)
lemma r_into_rtrancl: "<a,b> : r \<Longrightarrow> <a,b> : r^*"
  apply (rule rtrancl_refl [THEN rtrancl_into_rtrancl])
  apply assumption
  done

subsection \<open>standard induction rule\<close>

lemma rtrancl_full_induct:
  "\<lbrakk><a,b> : r^*;
      \<And>x. P(<x,x>);
      \<And>x y z. \<lbrakk>P(<x,y>); <x,y>: r^*; <y,z>: r\<rbrakk>  \<Longrightarrow> P(<x,z>)\<rbrakk>
   \<Longrightarrow>  P(<a,b>)"
  apply (erule def_induct [OF rtrancl_def])
   apply (rule rtrancl_fun_mono)
  apply blast
  done

(*nice induction rule*)
lemma rtrancl_induct:
  "\<lbrakk><a,b> : r^*;
      P(a);
      \<And>y z. \<lbrakk><a,y> : r^*; <y,z> : r;  P(y)\<rbrakk> \<Longrightarrow> P(z) \<rbrakk>
    \<Longrightarrow> P(b)"
(*by induction on this formula*)
  apply (subgoal_tac "ALL y. <a,b> = <a,y> \<longrightarrow> P(y)")
(*now solve first subgoal: this formula is sufficient*)
  apply blast
(*now do the induction*)
  apply (erule rtrancl_full_induct)
   apply blast
  apply blast
  done

(*transitivity of transitive closure!! -- by induction.*)
lemma trans_rtrancl: "trans(r^*)"
  apply (rule transI)
  apply (rule_tac b = z in rtrancl_induct)
    apply (fast elim: rtrancl_into_rtrancl)+
  done

(*elimination of rtrancl -- by induction on a special formula*)
lemma rtranclE:
  "\<lbrakk><a,b> : r^*; a = b \<Longrightarrow> P; \<And>y. \<lbrakk><a,y> : r^*; <y,b> : r\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  apply (subgoal_tac "a = b | (EX y. <a,y> : r^* \<and> <y,b> : r)")
   prefer 2
   apply (erule rtrancl_induct)
    apply blast
   apply blast
  apply blast
  done

subsection \<open>The relation trancl\<close>

subsubsection \<open>Conversions between trancl and rtrancl\<close>

lemma trancl_into_rtrancl: "<a,b> : r^+ \<Longrightarrow> <a,b> : r^*"
  apply (unfold trancl_def)
  apply (erule compEpair)
  apply (erule rtrancl_into_rtrancl)
  apply assumption
  done

(*r^+ contains r*)
lemma r_into_trancl: "<a,b> : r \<Longrightarrow> <a,b> : r^+"
  unfolding trancl_def by (blast intro: rtrancl_refl)

(*intro rule by definition: from rtrancl and r*)
lemma rtrancl_into_trancl1: "\<lbrakk><a,b> : r^*; <b,c> : r\<rbrakk> \<Longrightarrow> <a,c> : r^+"
  unfolding trancl_def by blast

(*intro rule from r and rtrancl*)
lemma rtrancl_into_trancl2: "\<lbrakk><a,b> : r; <b,c> : r^*\<rbrakk> \<Longrightarrow> <a,c> : r^+"
  apply (erule rtranclE)
   apply (erule subst)
   apply (erule r_into_trancl)
  apply (rule trans_rtrancl [THEN transD, THEN rtrancl_into_trancl1])
    apply (assumption | rule r_into_rtrancl)+
  done

(*elimination of r^+ -- NOT an induction rule*)
lemma tranclE:
  "\<lbrakk><a,b> : r^+;
    <a,b> : r \<Longrightarrow> P;
    \<And>y. \<lbrakk><a,y> : r^+; <y,b> : r\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  apply (subgoal_tac "<a,b> : r | (EX y. <a,y> : r^+ \<and> <y,b> : r)")
   apply blast
  apply (unfold trancl_def)
  apply (erule compEpair)
  apply (erule rtranclE)
   apply blast
  apply (blast intro!: rtrancl_into_trancl1)
  done

(*Transitivity of r^+.
  Proved by unfolding since it uses transitivity of rtrancl. *)
lemma trans_trancl: "trans(r^+)"
  apply (unfold trancl_def)
  apply (rule transI)
  apply (erule compEpair)+
  apply (erule rtrancl_into_rtrancl [THEN trans_rtrancl [THEN transD, THEN compI]])
    apply assumption+
  done

lemma trancl_into_trancl2: "\<lbrakk><a,b> : r; <b,c> : r^+\<rbrakk> \<Longrightarrow> <a,c> : r^+"
  by (rule r_into_trancl [THEN trans_trancl [THEN transD]])

end


theory Prop
imports Main
begin
datatype bool = True | False
fun conj :: "bool => bool \<Rightarrow> bool" where
"conj True True = True" |
"conj _ _ = False"

fun disjunc :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"disjunc False False = False" |
"disjunc _ _ = True"

datatype natt = Z | Succ natt

fun addd :: "natt \<Rightarrow> natt \<Rightarrow> natt" where
 "addd Z n = n" |
 "addd (Succ m) n = Succ (addd m n)"

lemma addzeroright[simp] : "addd m Z = m"
apply (induction m) apply (auto)
done

lemma addassociativity[simp] : "addd (addd m n) p = addd m (addd n p)"
apply (induction m)  apply auto
done
lemma addsucc[simp] : "addd x (Succ y) = Succ (addd x y)"
apply (induction x) apply auto done

lemma addcommutative[simp] : "addd x y = addd y x"
apply (induction x)  apply auto done

fun double :: "natt \<Rightarrow> natt" where
  "double Z = Z" |
  "double (Succ n) = Succ (Succ (double n))"

lemma add_double : "addd n n = double n"
apply (induction n) apply auto done

datatype 'a list = Nil | Cons 'a "'a list"

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev (Cons True (Cons False Nil))"
value "rec (Cons a (Cons b Nil))"

(* if you don't add [simp] then use apply (simp add: lemmaOne lemmaTow) *)
lemma app_nil[simp] : "app xs Nil = xs"
apply (induction xs) apply auto  done

lemma app_associate[simp] : "app (app xs ys) zs = app xs (app ys zs)"
apply (induction xs) apply auto done

lemma rev_app[simp] : "rev (app xs ys) = app (rev ys) (rev xs)"
apply (induction xs) apply auto
done

theorem rev_rev[simp] : "rev (rev xs) = xs"
apply (induction xs)
apply auto done

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> natt" where
  "count x Nil = Z" |
  "count x (Cons y ys) =
    (if x = y then Succ (count x ys) else (count x ys))"

fun length :: "'a list \<Rightarrow> natt" where
  "length Nil = Z" |
  "length (Cons x xs) = Succ (length xs)"

value "length (Cons a (Cons b (Cons c Nil)))"
end


theory P9 imports Main P6 begin
fun ListSum :: "nat list \<Rightarrow> nat" where
"ListSum Nil = 0" | "ListSum (x # xs) = (x + ListSum xs)"

theorem "2 * ListSum [0..<n+1] = n * (n + 1)"
  apply (induct n)
   apply auto
  done

theorem "ListSum (replicate n a) = n * a"
  apply (induct n)
   apply auto
  done

fun ListSumTAux :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
"ListSumTAux Nil a = a" | "ListSumTAux (x # xs) a = (ListSumTAux xs (x+a))"

fun ListSumT :: "nat list \<Rightarrow> nat" where
"ListSumT xs = ListSumTAux xs 0"

lemma move_a: "\<forall>a. \<forall>b. ListSumTAux xs (a + b) = (ListSumTAux (a # xs) b)"
  apply simp
  done

lemma [simp]: "\<forall>y. x + ListSumTAux xs y = ListSumTAux xs (x + y)"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case
  proof -
    assume "\<forall>y. x + ListSumTAux xs y = ListSumTAux xs (x + y)"
    have 1: "x + ListSumTAux (a # xs) y = x + (ListSumTAux xs (a + y))"
      using ListSumTAux.simps(2)
      by presburger
    then show ?thesis
      by (simp add: Cons.hyps add.left_commute)
      qed
qed

theorem "ListSum xs = ListSumT xs"
  apply (induct xs)
   apply auto
  done

end