(*  Author:     Tobias Nipkow, 2007  *)

header "Arrow's Theorem for Strict Linear Orders"

theory Arrow_Order imports Main "~~/src/HOL/Library/FuncSet"
begin

text{* This theory formalizes the third proof due to
Geanakoplos~\cite{Geanakoplos05}.  Preferences are modeled as strict
linear orderings. The set of alternatives need not be finite.

Individuals are assumed to be finite but are not a priori identified with an
initial segment of the naturals. In retrospect this generality appears
gratuitous and complicates some of the low-level reasoning where we use a
bijection with such an initial segment.  *}

typedecl alt
typedecl indi

abbreviation "I == (UNIV::indi set)"

axiomatization where
  alt3: "\<exists>a b c::alt. distinct[a,b,c]" and
  finite_indi: "finite I"

abbreviation "N == card I"

lemma third_alt: "a \<noteq> b \<Longrightarrow> \<exists>c::alt. distinct[a,b,c]"
using alt3 by simp metis

lemma alt2: "\<exists>b::alt. b \<noteq> a"
using alt3 by simp metis

type_synonym pref = "(alt * alt)set"

definition "Lin == {L::pref. strict_linear_order L}"

lemmas slo_defs = Lin_def strict_linear_order_on_def total_on_def irrefl_def

lemma notin_Lin_iff: "L : Lin \<Longrightarrow> x\<noteq>y \<Longrightarrow> (x,y) \<notin> L \<longleftrightarrow> (y,x) : L"
apply(auto simp add: slo_defs)
apply(metis trans_def)
done

lemma converse_in_Lin[simp]: "L\<inverse> : Lin \<longleftrightarrow> L : Lin"
apply (simp add: slo_defs)
apply blast
done

lemma Lin_irrefl: "L:Lin \<Longrightarrow> (a,b):L \<Longrightarrow> (b,a):L \<Longrightarrow> False"
by(simp add:slo_defs)(metis trans_def)

corollary linear_alt: "\<exists>L::pref. L : Lin"
using well_order_on[where 'a = "alt", of UNIV]
apply (auto simp:well_order_on_def Lin_def)
apply (metis strict_linear_order_on_diff_Id)
done

abbreviation
 rem :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"rem L a \<equiv> {(x,y). (x,y) \<in> L \<and> x\<noteq>a \<and> y\<noteq>a}"
definition
 mktop :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mktop L b \<equiv> rem L b \<union> {(x,b)|x. x\<noteq>b}"
definition
 mkbot :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mkbot L b \<equiv> rem L b \<union> {(b,y)|y. y\<noteq>b}"
definition
 below :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"below L a b \<equiv> rem L a \<union>
  {(a,b)} \<union> {(x,a)|x. (x,b) : L \<and> x\<noteq>a} \<union> {(a,y)|y. (b,y) : L \<and> y\<noteq>a}"
definition
 above :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"above L a b \<equiv> rem L b \<union>
  {(a,b)} \<union> {(x,b)|x. (x,a) : L \<and> x\<noteq>b} \<union> {(b,y)|y. (a,y) : L \<and> y\<noteq>b}"

lemma in_mktop: "(x,y) \<in> mktop L z \<longleftrightarrow> x\<noteq>z \<and> (if y=z then x\<noteq>y else (x,y) \<in> L)"
by(auto simp:mktop_def)

lemma in_mkbot: "(x,y) \<in> mkbot L z \<longleftrightarrow> y\<noteq>z \<and> (if x=z then x\<noteq>y else (x,y) \<in> L)"
by(auto simp:mkbot_def)

lemma in_above: "a\<noteq>b \<Longrightarrow> L:Lin \<Longrightarrow>
  (x,y) : above L a b \<longleftrightarrow> x\<noteq>y \<and>
  (if x=b then (a,y) : L else
   if y=b then x=a | (x,a) : L else (x,y) : L)"
by(auto simp:above_def slo_defs)

lemma in_below: "a\<noteq>b \<Longrightarrow> L:Lin \<Longrightarrow>
  (x,y) : below L a b \<longleftrightarrow> x\<noteq>y \<and>
  (if y=a then (x,b) : L else
   if x=a then y=b | (b,y) : L else (x,y) : L)"
by(auto simp:below_def slo_defs)

declare [[simp_depth_limit = 2]]

lemma mktop_Lin: "L : Lin \<Longrightarrow> mktop L x : Lin"
by(auto simp add:slo_defs mktop_def trans_def)
lemma mkbot_Lin: "L : Lin \<Longrightarrow> mkbot L x : Lin"
by(auto simp add:slo_defs trans_def mkbot_def)

lemma below_Lin: "x\<noteq>y \<Longrightarrow> L : Lin \<Longrightarrow> below L x y : Lin"
unfolding slo_defs below_def trans_def
apply(simp)
apply blast
done

lemma above_Lin: "x\<noteq>y \<Longrightarrow> L : Lin \<Longrightarrow> above L x y : Lin"
unfolding slo_defs above_def trans_def
apply(simp)
apply blast
done

declare [[simp_depth_limit = 50]]

abbreviation lessLin :: "alt \<Rightarrow> pref \<Rightarrow> alt \<Rightarrow> bool" ("(_ <\<^bsub>_\<^esub> _)" [51, 51] 50)
where "a <\<^bsub>L\<^esub> b == (a,b) : L"

definition "Prof = I \<rightarrow> Lin"

abbreviation "SWF == Prof \<rightarrow> Lin"

definition "unanimity F == \<forall>P\<in>Prof.\<forall>a b. (\<forall>i. a <\<^bsub>P i\<^esub> b) \<longrightarrow>  a <\<^bsub>F P\<^esub> b"

definition "IIA F == \<forall>P\<in>Prof.\<forall>P'\<in>Prof.\<forall>a b.
   (\<forall>i. a <\<^bsub>P i\<^esub> b \<longleftrightarrow> a <\<^bsub>P' i\<^esub> b) \<longrightarrow> (a <\<^bsub>F P\<^esub> b \<longleftrightarrow> a <\<^bsub>F P'\<^esub> b)"

definition "dictator F i == \<forall>P\<in>Prof. F P = P i"

lemma dictatorI: "F : SWF \<Longrightarrow>
  \<forall>P\<in>Prof. \<forall>a b. a \<noteq> b \<longrightarrow> (a,b) : P i \<longrightarrow> (a,b) : F P \<Longrightarrow> dictator F i"
apply(simp add:dictator_def Prof_def Pi_def Lin_def strict_linear_order_on_def)
apply safe
 apply(erule_tac x=P in allE)
 apply(erule_tac x=P in allE)
 apply(simp add:total_on_def irrefl_def)
 apply (metis trans_def)
apply (metis irrefl_def)
done

lemma const_Lin_Prof: "L:Lin \<Longrightarrow> (%p. L) : Prof"
by(simp add:Prof_def Pi_def)

lemma complete_Lin: assumes "a\<noteq>b" shows "EX L:Lin. (a,b) : L"
proof -
  from linear_alt obtain R where "R:Lin" by auto
  thus ?thesis by (metis assms in_mkbot mkbot_Lin)
qed

declare Let_def[simp]

theorem Arrow: assumes "F : SWF" and u: "unanimity F" and "IIA F"
shows "EX i. dictator F i"
proof -
  { fix a b a' b' and P P'
    assume d1: "a\<noteq>b" "a'\<noteq>b'" and d2: "a\<noteq>b'" "b\<noteq>a'" and
      "P : Prof" "P' : Prof" and 1: "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    assume "(a,b) : F P"
    def Q \<equiv> "%i. let L = (if a=a' then P i else below (P i) a' a)
                  in if b=b' then L else above L b b'"
    have "Q : Prof" using `P : Prof`
      by(simp add:Q_def Prof_def Pi_def above_Lin below_Lin)
    hence "F Q : Lin" using `F : SWF` by(simp add:Pi_def)
    have "\<forall>i. (a,b) : P i \<longleftrightarrow> (a,b) : Q i" using d1 d2 `P : Prof`
      by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
    hence "(a,b) : F Q" using `(a,b) : F P` `IIA F` `P:Prof` `Q : Prof`
      unfolding IIA_def by blast
    moreover
    { assume "a\<noteq>a'"
      hence "!!i. (a',a) : Q i" using d1 d2 `P : Prof`
        by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
      hence "(a',a) : F Q" using u `Q : Prof` by(simp add:unanimity_def)
    } moreover
    { assume "b\<noteq>b'"
      hence "!!i. (b,b') : Q i" using d1 d2 `P : Prof`
        by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
      hence "(b,b') : F Q" using u `Q : Prof` by(simp add:unanimity_def)
    }
    ultimately have "(a',b') : F Q" using `F Q : Lin`
      unfolding slo_defs trans_def by blast
    moreover
    have "\<forall>i. (a',b') : Q i \<longleftrightarrow> (a',b') : P' i" using d1 d2 `P : Prof` 1
      by(simp add:Q_def in_below in_above Prof_def Pi_def below_Lin) blast
    ultimately have "(a',b') : F P'"
      using `IIA F` `P' : Prof` `Q : Prof` unfolding IIA_def by blast
  } note 1 = this
  { fix a b a' b' and P P'
    assume "a\<noteq>b" "a'\<noteq>b'" "a\<noteq>b'" "b\<noteq>a'" "P : Prof" "P' : Prof"
           "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    hence "(a,b) : F P \<longleftrightarrow> (a',b') : F P'" using 1 by blast
  } note 2 = this
  { fix a b P P'
    assume "a\<noteq>b" "P : Prof" "P' : Prof" and
      iff: "\<forall>i. (a,b) : P i \<longleftrightarrow> (b,a) : P' i"
    from `a\<noteq>b` obtain c where dist: "distinct[a,b,c]" using third_alt by metis
    let ?Q = "%p. below (P p) c b"
    let ?R = "%p. below (?Q p) b a"
    let ?S = "%p. below (?R p) a c"
    have "?Q : Prof" using `P : Prof` dist
      by(auto simp add:Prof_def Pi_def below_Lin)
    hence "?R : Prof" using dist by(auto simp add:Prof_def Pi_def below_Lin)
    hence "?S : Prof" using dist by(auto simp add:Prof_def Pi_def below_Lin)
    have "\<forall>i. (a,b) : P i \<longleftrightarrow> (a,c) : ?Q i" using `P : Prof` dist
      by(auto simp add:in_below Prof_def Pi_def)
    hence ab: "(a,b) : F P \<longleftrightarrow> (a,c) : F ?Q"
      using 2 `P : Prof` `?Q : Prof` dist[simplified] by (blast)
    have "\<forall>i. (a,c) : ?Q i \<longleftrightarrow> (b,c) : ?R i" using `P : Prof` dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence ac: "(a,c) : F ?Q \<longleftrightarrow> (b,c) : F ?R"
      using 2 `?Q : Prof` `?R : Prof` dist[simplified] by (blast)
    have "\<forall>i. (b,c) : ?R i \<longleftrightarrow> (b,a) : ?S i" using `P : Prof` dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence bc: "(b,c) : F ?R \<longleftrightarrow> (b,a) : F ?S"
      using `?R : Prof` `?S : Prof` dist[simplified] 2
      apply -
      apply(rule 2)
      by fast+
    have "\<forall>i. (b,a) : ?S i \<longleftrightarrow> (a,b) : P i" using `P : Prof` dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence "\<forall>i. (b,a) : ?S i \<longleftrightarrow> (b,a) : P' i" using iff by blast
    hence ba: "(b,a) : F ?S \<longleftrightarrow> (b,a) : F P'"
      using `IIA F` `P' : Prof` `?S : Prof` unfolding IIA_def by fast
    from ab ac bc ba have "(a,b) : F P \<longleftrightarrow> (b,a) : F P'" by simp
  } note 3 = this
  { fix a b c P P'
    assume A: "a\<noteq>b" "b\<noteq>c" "a\<noteq>c" "P : Prof" "P' : Prof" and
      iff: "\<forall>i. (a,b) : P i \<longleftrightarrow> (b,c) : P' i"
    hence "\<forall>i. (b,a) : (converse o P)i \<longleftrightarrow> (b,c) : P' i" by simp
    moreover have cP: "converse o P : Prof"
      using `P:Prof` by(simp add:Prof_def Pi_def)
    ultimately have "(b,a) : F(converse o P) \<longleftrightarrow> (b,c) : F P'" using A 2
      by metis
    moreover have "(a,b) : F P \<longleftrightarrow> (b,a) : F(converse o P)"
      by (rule 3[OF `a\<noteq>b` `P:Prof` cP]) simp
    ultimately have "(a,b) : F P \<longleftrightarrow> (b,c) : F P'" by blast
  } note 4 = this
  { fix a b a' b' :: alt and P P'
    assume A: "a\<noteq>b" "a'\<noteq>b'" "P : Prof" "P' : Prof"
      "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    have "(a,b) : F P \<longleftrightarrow> (a',b') : F P'"
    proof-
      { assume "a\<noteq>b' & b\<noteq>a'" hence ?thesis using 2 A by blast }
      moreover
      { assume "a=b' & b\<noteq>a'" hence ?thesis using 4 A by blast }
      moreover
      { assume "a\<noteq>b' & b=a'" hence ?thesis using 4 A by blast }
      moreover
      { assume "a=b' & b=a'" hence ?thesis using 3 A by blast }
      ultimately show ?thesis by blast
    qed
  } note pairwise_neutrality = this
  obtain h :: "indi \<Rightarrow> nat" where
    injh: "inj h" and surjh: "h ` I = {0..<N}"
    by(metis ex_bij_betw_finite_nat[OF finite_indi] bij_betw_def)
  obtain a b :: alt where "a \<noteq> b" using alt3 by auto
  obtain Lab where "(a,b) : Lab" "Lab:Lin" using `a\<noteq>b` by (metis complete_Lin)
  hence "(b,a) \<notin> Lab" by(simp add:slo_defs trans_def) metis
  obtain Lba where "(b,a) : Lba" "Lba:Lin" using `a\<noteq>b` by (metis complete_Lin)
  hence "(a,b) \<notin> Lba" by(simp add:slo_defs trans_def) metis
  let ?Pi = "%n. %i. if h i < n then Lab else Lba"
  have PiProf: "!!n. ?Pi n : Prof" using `Lab:Lin` `Lba:Lin`
    unfolding Prof_def Pi_def by simp
  have "EX n<N. (\<forall>m\<le>n. (b,a) : F(?Pi m)) & (a,b) : F(?Pi(n+1))"
  proof -
    have 0: "!!n. F(?Pi n) : Lin" using `F : SWF` PiProf by(simp add:Pi_def)
    have "F(%i. Lba):Lin" using `F:SWF` `Lba:Lin` by(simp add:Prof_def Pi_def)
    hence 1: "(a,b) \<notin> F(?Pi 0)" using u `(a,b) \<notin> Lba` `Lba:Lin` `Lba:Lin` `a\<noteq>b`
      by(simp add:unanimity_def notin_Lin_iff const_Lin_Prof)
    have "?Pi N = (%p. Lab)" using surjh [THEN equalityD1]
      by(auto simp: subset_eq)
    moreover
    have "F(%i. Lab):Lin" using `F:SWF` `Lab:Lin` by(simp add:Prof_def Pi_def)
    ultimately have 2: "(a,b) \<in> F(?Pi N)" using u `(a,b) : Lab` `Lab:Lin`
      by(simp add:unanimity_def const_Lin_Prof)
    with ex_least_nat_less[of "%n. (a,b) : F(?Pi n)",OF 1 2]
      notin_Lin_iff[OF 0 `a\<noteq>b`]
    show ?thesis by simp
  qed
  then obtain n where n: "n<N" "\<forall>m\<le>n. (b,a) : F(?Pi m)" "(a,b) : F(?Pi(n+1))"
    by blast
  have "dictator F (inv h n)"
  proof (rule dictatorI [OF `F : SWF`], auto)
    fix P c d assume "P \<in> Prof" "c\<noteq>d" "(c,d) \<in> P(inv h n)"
    then obtain e where dist: "distinct[c,d,e]" using third_alt by metis
    let ?W = "%i. if h i < n then mktop (P i) e else
                  if h i = n then above (P i) c e else mkbot (P i) e"
    have "?W : Prof" using `P : Prof` dist
      by(simp add:Pi_def Prof_def mkbot_Lin mktop_Lin above_Lin)
    have "\<forall>i. (c,d) : P i \<longleftrightarrow> (c,d) : ?W i" using dist `P : Prof`
      by(auto simp: in_above in_mkbot in_mktop Prof_def Pi_def)
    hence PW: "(c,d) : F P \<longleftrightarrow> (c,d) : F ?W"
      using `IIA F`[unfolded IIA_def] `P:Prof` `?W:Prof` by fast
    have "\<forall>i. (c,e) : ?W i \<longleftrightarrow> (a,b) : ?Pi (n+1) i" using dist `P : Prof`
      by (auto simp: `(a,b):Lab` `(a,b)\<notin>Lba`
        in_mkbot in_mktop in_above Prof_def Pi_def)
    hence "(c,e) : F ?W \<longleftrightarrow> (a,b) : F(?Pi(n+1))"
      using pairwise_neutrality[of c e a b ?W "?Pi(n+1)"]
        `a\<noteq>b` dist `?W : Prof` PiProf by simp
    hence "(c,e) : F ?W" using n(3) by blast
    have "\<forall>i. (e,d) : ?W i \<longleftrightarrow> (b,a) : ?Pi n i"
      using dist `P : Prof` `(c,d) \<in> P(inv h n)` `inj h`
      by(auto simp: `(b,a):Lba` `(b,a)\<notin>Lab`
        in_mkbot in_mktop in_above Prof_def Pi_def)
    hence "(e,d) : F ?W \<longleftrightarrow> (b,a) : F(?Pi n)"
      using pairwise_neutrality[of e d b a ?W "?Pi n"]
        `a\<noteq>b` dist `?W : Prof` PiProf by simp blast
    hence "(e,d) : F ?W" using n(2) by auto
    with `(c,e) : F ?W` `?W : Prof` `F:SWF`
    have "(c,d) \<in> F ?W" unfolding Pi_def slo_defs trans_def by blast
    thus "(c,d) \<in> F P" using PW by blast
  qed
  thus ?thesis ..
qed

end


(*  Title:      FOL/ex/Nat.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Theory of the natural numbers: Peano's axioms, primitive recursion\<close>

theory Nat
imports FOL
begin

typedecl nat
instance nat :: "term" ..

axiomatization
  Zero :: nat  ("0") and
  Suc :: "nat => nat" and
  rec :: "[nat, 'a, [nat, 'a] => 'a] => 'a"
where
  induct: "[| P(0);  !!x. P(x) ==> P(Suc(x)) |]  ==> P(n)" and
  Suc_inject: "Suc(m)=Suc(n) ==> m=n" and
  Suc_neq_0: "Suc(m)=0 ==> R" and
  rec_0: "rec(0,a,f) = a" and
  rec_Suc: "rec(Suc(m), a, f) = f(m, rec(m,a,f))"

definition add :: "[nat, nat] => nat"  (infixl "+" 60)
  where "m + n == rec(m, n, %x y. Suc(y))"

subsection \<open>Proofs about the natural numbers\<close>

lemma Suc_n_not_n: "Suc(k) \<noteq> k"
apply (rule_tac n = k in induct)
apply (rule notI)
apply (erule Suc_neq_0)
apply (rule notI)
apply (erule notE)
apply (erule Suc_inject)
done

lemma "(k+m)+n = k+(m+n)"
apply (rule induct)
back
back
back
back
back
back
oops

lemma add_0 [simp]: "0+n = n"
apply (unfold add_def)
apply (rule rec_0)
done

lemma add_Suc [simp]: "Suc(m)+n = Suc(m+n)"
apply (unfold add_def)
apply (rule rec_Suc)
done

lemma add_0_right: "m+0 = m"
apply (rule_tac n = m in induct)
apply simp
apply simp
done

lemma add_Suc_right: "m+Suc(n) = Suc(m+n)"
apply (rule_tac n = m in induct)
apply simp_all
done

lemma
  assumes prem: "!!n. f(Suc(n)) = Suc(f(n))"
  shows "f(i+j) = i+f(j)"
apply (rule_tac n = i in induct)
apply simp
apply (simp add: prem)
done

end


subsection \<open>Diophantine Relations and Predicates\<close>

theory Diophantine_Relations
  imports Assignments
begin

datatype relation =
  NARY "nat list \<Rightarrow> bool" "polynomial list"
    | AND relation relation (infixl "[\<and>]" 35)
    | OR  relation relation (infixl "[\<or>]" 30)
    | EXIST_LIST nat relation ("[\<exists>_] _" 10)

fun eval :: "relation \<Rightarrow> assignment \<Rightarrow> bool" where
  "eval (NARY R PL) a = R (map (\<lambda>P. peval P a) PL)"
    | "eval (AND D1 D2) a = (eval D1 a \<and> eval D2 a)"
    | "eval (OR D1 D2) a = (eval D1 a \<or> eval D2 a)"
    | "eval ([\<exists>n] D) a = (\<exists>ks::nat list. n = length ks \<and> eval D (push_list a ks))"

definition is_dioph_rel :: "relation \<Rightarrow> bool" where
  "is_dioph_rel DR = (\<exists>P\<^sub>1 P\<^sub>2::ppolynomial. \<forall>a. (eval DR a) \<longleftrightarrow> (\<exists>v. ppeval P\<^sub>1 a v = ppeval P\<^sub>2 a v))"

definition UNARY :: "(nat \<Rightarrow> bool) \<Rightarrow> polynomial \<Rightarrow> relation" where
  "UNARY R P = NARY (\<lambda>l. R (l!0)) [P]"

lemma unary_eval: "eval (UNARY R P) a = R (peval P a)"
  unfolding UNARY_def by simp

definition BINARY :: "(nat \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> polynomial \<Rightarrow> polynomial \<Rightarrow> relation" where
  "BINARY R P\<^sub>1 P\<^sub>2 = NARY (\<lambda>l. R (l!0) (l!1)) [P\<^sub>1, P\<^sub>2]"

lemma binary_eval: "eval (BINARY R P\<^sub>1 P\<^sub>2) a = R (peval P\<^sub>1 a) (peval P\<^sub>2 a)"
  unfolding BINARY_def by simp

definition TERNARY :: "(nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool)
                        \<Rightarrow> polynomial \<Rightarrow> polynomial \<Rightarrow> polynomial \<Rightarrow> relation" where
  "TERNARY R P\<^sub>1 P\<^sub>2 P\<^sub>3 = NARY (\<lambda>l. R (l!0) (l!1) (l!2)) [P\<^sub>1, P\<^sub>2, P\<^sub>3]"

lemma ternary_eval: "eval (TERNARY R P\<^sub>1 P\<^sub>2 P\<^sub>3) a = R (peval P\<^sub>1 a) (peval P\<^sub>2 a) (peval P\<^sub>3 a)"
  unfolding TERNARY_def by simp

definition QUATERNARY :: "(nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool)
                        \<Rightarrow> polynomial \<Rightarrow> polynomial \<Rightarrow> polynomial \<Rightarrow> polynomial \<Rightarrow> relation" where
  "QUATERNARY R P\<^sub>1 P\<^sub>2 P\<^sub>3 P\<^sub>4 = NARY (\<lambda>l. R (l!0) (l!1) (l!2) (l!3)) [P\<^sub>1, P\<^sub>2, P\<^sub>3, P\<^sub>4]"

definition EXIST :: "relation \<Rightarrow> relation" ("[\<exists>] _" 10) where
  "([\<exists>] D) = ([\<exists>1] D)"

definition TRUE where "TRUE = UNARY ((=) 0) (Const 0)"

text \<open>Bounded constant all quantifier (i.e. recursive conjunction)\<close>
fun ALLC_LIST :: "nat list \<Rightarrow> (nat \<Rightarrow> relation) \<Rightarrow> relation" ("[\<forall> in _] _") where
  "[\<forall> in []] DF = TRUE" |
  "[\<forall> in (l # ls)] DF = (DF l [\<and>] [\<forall> in ls] DF)"

lemma ALLC_LIST_eval_list_all: "eval ([\<forall> in L] DF) a = list_all (\<lambda>l. eval (DF l) a) L"
  by (induction L, auto simp: TRUE_def UNARY_def)

lemma ALLC_LIST_eval:  "eval ([\<forall> in L] DF) a = (\<forall>k<length L. eval (DF (L!k)) a)"
  by (simp add: ALLC_LIST_eval_list_all list_all_length)

definition ALLC :: "nat \<Rightarrow> (nat \<Rightarrow> relation) \<Rightarrow> relation" ("[\<forall><_] _") where
  "[\<forall><n] D \<equiv> [\<forall> in [0..<n]] D"

lemma ALLC_eval: "eval ([\<forall><n] DF) a = (\<forall>k<n. eval (DF k) a)"
  unfolding ALLC_def by (simp add: ALLC_LIST_eval)

fun concat :: "'a list list \<Rightarrow> 'a list" where
  "concat [] = []" |
  "concat (l # ls) = l @ concat ls"

fun splits :: "'a list \<Rightarrow> nat list \<Rightarrow> 'a list list" where
  "splits L [] = []" |
  "splits L (n # ns) = (take n L) # (splits (drop n L) ns)"

lemma split_concat:
  "splits (map f (concat pls)) (map length pls) = map (map f) pls"
  by (induction pls, auto)

definition LARY :: "(nat list list \<Rightarrow> bool) \<Rightarrow> (polynomial list list) \<Rightarrow> relation" where
  "LARY R PLL = NARY (\<lambda>l. R (splits l (map length PLL))) (concat PLL)"

lemma LARY_eval:
  fixes PLL :: "polynomial list list"
  shows "eval (LARY R PLL) a = R (map (map (\<lambda>P. peval P a)) PLL)"
  unfolding LARY_def apply (induction PLL, simp)
  subgoal for pl pls by (induction pl, auto simp: split_concat)
  done

lemma or_dioph:
  assumes "is_dioph_rel A" and "is_dioph_rel B"
  shows "is_dioph_rel (A [\<or>] B)"
proof -
  from assms obtain PA1 PA2 where PA: "\<forall>a. (eval A a) \<longleftrightarrow> (\<exists>v. ppeval PA1 a v = ppeval PA2 a v)"
    by (auto simp: is_dioph_rel_def)
  from assms obtain PB1 PB2 where PB: "\<forall>a. (eval B a) \<longleftrightarrow> (\<exists>v. ppeval PB1 a v = ppeval PB2 a v)"
    by (auto simp: is_dioph_rel_def)

  (* OR means (A1 - A2) * (B1 - B2) = 0
     Rewrite as A1*B1 + A2*B2 = A1*B2 + A2*B1 to eliminate subtraction. *)
  show ?thesis
    unfolding is_dioph_rel_def
    apply (rule exI[of _ "PA1 \<^bold>* PB1 \<^bold>+ PA2 \<^bold>* PB2"])
    apply (rule exI[of _ "PA1 \<^bold>* PB2 \<^bold>+ PA2 \<^bold>* PB1"])
    using PA PB by (auto) (metis crossproduct_eq add.commute)+
    (* For each subgoal, a different fact is unused. The warning is due to 'metis+' being used. *)
qed

lemma exists_disjoint_vars:
  fixes Q1 Q2 :: ppolynomial
  fixes A :: relation
  assumes "is_dioph_rel A"
  shows "\<exists>P1 P2. disjoint_var (P1 \<^bold>+ P2) (Q1 \<^bold>+ Q2)
                \<and> (\<forall>a. eval A a \<longleftrightarrow> (\<exists>v. ppeval P1 a v = ppeval P2 a v))"
proof -
  obtain P1 P2 where p_defs: "\<forall>a. eval A a \<longleftrightarrow> (\<exists>v. ppeval P1 a v = ppeval P2 a v)"
    using assms is_dioph_rel_def by auto

  define n::nat where "n \<equiv> Max (var_set (Q1 \<^bold>+ Q2))"

  define P1' P2' where p'_defs: "P1' \<equiv> push_var P1 (Suc n)" "P2' \<equiv> push_var P2 (Suc n)"

  have "disjoint_var (P1' \<^bold>+ P2') (Q1 \<^bold>+ Q2)"
  proof -
    have "finite (var_set (Q1 \<^bold>+ Q2))"
      apply (induction Q1, auto)
      by (induction Q2, auto)+

    hence "\<forall>x \<in> var_set (Q1 \<^bold>+ Q2). x \<le> n"
      unfolding n_def using Max.coboundedI by blast

    moreover have "\<forall>x \<in> var_set (P1' \<^bold>+ P2'). x > n"
      unfolding p'_defs using push_var_bound by auto

    ultimately show ?thesis
      unfolding disjoint_var_def by fastforce
  qed

  moreover have "\<forall>a. eval A a \<longleftrightarrow> (\<exists>v. ppeval P1' a v = ppeval P2' a v)"
    unfolding p'_defs apply (auto simp add: p_defs push_var_pull_assignment pull_assignment_def)
    subgoal for a v by (rule exI[of _ "\<lambda>i. v (i - Suc n)"]) auto
    done

  ultimately show ?thesis
    by auto
qed

(* Combine the two results to show that AND has a diophantine representation *)
lemma and_dioph:
  assumes "is_dioph_rel A" and "is_dioph_rel B"
  shows "is_dioph_rel (A [\<and>] B)"
proof -
  from assms(1) obtain PA1 PA2 where PA: "\<forall>a. (eval A a) \<longleftrightarrow> (\<exists>v. ppeval PA1 a v = ppeval PA2 a v)"
    by (auto simp: is_dioph_rel_def)
  from assms(2) obtain PB1 PB2 where disj: "disjoint_var (PB1 \<^bold>+ PB2) (PA1 \<^bold>+ PA2)"
                                   and PB: "(\<forall>a. eval B a \<longleftrightarrow> (\<exists>v. ppeval PB1 a v = ppeval PB2 a v))"
    using exists_disjoint_vars[of B] by blast

  from disjoint_var_unifies have unified: "\<forall>a. (eval (A [\<and>] B) a)
                        \<longleftrightarrow> (\<exists>v. ppeval PA1 a v = ppeval PA2 a v \<and> ppeval PB1 a v = ppeval PB2 a v)"
    using PA PB disj disjoint_var_sym by simp blast

  (* AND means (A1 - A2)^2 + (B1 - B2)^2 = 0
     Rewrite as A1^2 + A2^2 + B1^2 + B2^2 = 2*A1*A2 + 2*B1*B2 to eliminate subtraction. *)
  have h0: "p1 = p2 \<longleftrightarrow> p1^2 + p2^2 = 2*p1*p2" for p1 p2 :: nat
    apply (auto simp: algebra_simps power2_eq_square)
    using crossproduct_eq by fastforce

  have "p1 = p2 \<and> q1 = q2 \<longleftrightarrow> p1^2 + p2^2 + q1^2 + q2^2 = 2*p1*p2 + 2*q1*q2" for p1 p2 q1 q2 :: nat
  proof (rule)
    assume "p1 = p2 \<and> q1 = q2"
    thus "p1\<^sup>2 + p2\<^sup>2 + q1\<^sup>2 + q2\<^sup>2 = 2 * p1 * p2 + 2 * q1 * q2"
      by (auto simp: algebra_simps power2_eq_square)
  next
    assume "p1\<^sup>2 + p2\<^sup>2 + q1\<^sup>2 + q2\<^sup>2 = 2 * p1 * p2 + 2 * q1 * q2"
    hence "(int p1)\<^sup>2 + (int p2)\<^sup>2 + (int q1)\<^sup>2 + (int q2)\<^sup>2 - 2 * int p1 * int p2 - 2 * int q1 * int q2 = 0"
      by (auto) (smt (verit, best) mult_2 of_nat_add of_nat_mult power2_eq_square)
    hence "(int p1 - int p2)^2 + (int q1 - int q2)^2 = 0"
      by (simp add: power2_diff)
    hence "int p1 = int p2" and "int q1 = int q2"
      by (simp add: sum_power2_eq_zero_iff)+
    thus "p1 = p2 \<and> q1 = q2"
      by auto
  qed

  thus ?thesis
    apply (simp only: is_dioph_rel_def)
    apply (rule exI[of _ "PA1\<^bold>^\<^bold>2 \<^bold>+ PA2\<^bold>^\<^bold>2 \<^bold>+ PB1\<^bold>^\<^bold>2 \<^bold>+ PB2\<^bold>^\<^bold>2"])
    apply (rule exI[of _ "(ppolynomial.Const 2) \<^bold>* PA1 \<^bold>* PA2 \<^bold>+ (ppolynomial.Const 2) \<^bold>* PB1 \<^bold>* PB2"])
    apply (subst unified)
    by (simp add: Sq_pp_def power2_eq_square)
qed

(* Some basic relations are diophantine *)
definition eq (infix "[=]" 50) where "eq Q R \<equiv> BINARY (=) Q R"
definition lt (infix "[<]" 50) where "lt Q R \<equiv> BINARY (<) Q R"
definition le (infix "[\<le>]" 50) where "le Q R \<equiv> Q [<] R [\<or>] Q [=] R"
definition gt (infix "[>]" 50) where "gt Q R \<equiv> R [<] Q"
definition ge (infix "[\<ge>]" 50) where "ge Q R \<equiv> Q [>] R [\<or>] Q [=] R"

named_theorems defs
lemmas [defs] = zero_p_def one_p_def eq_def lt_def le_def gt_def ge_def LARY_eval
                UNARY_def BINARY_def TERNARY_def QUATERNARY_def ALLC_LIST_eval ALLC_eval

named_theorems dioph
lemmas [dioph] = or_dioph and_dioph

lemma true_dioph[dioph]: "is_dioph_rel TRUE"
  unfolding TRUE_def UNARY_def is_dioph_rel_def by auto

lemma eq_dioph[dioph]: "is_dioph_rel (Q [=] R)"
  unfolding is_dioph_rel_def
  apply (rule exI[of _ "convert Q"])
  apply (rule exI[of _ "convert R"])
  using convert_eval BINARY_def by (auto simp: eq_def)

lemma lt_dioph[dioph]: "is_dioph_rel (Q [<] R)"
  unfolding is_dioph_rel_def
  apply (rule exI[of _ "(ppolynomial.Const 1) \<^bold>+ (ppolynomial.Var 0) \<^bold>+ convert Q"])
  apply (rule exI[of _ "convert R"])
  using convert_eval BINARY_def apply (auto simp: lt_def)
  by (metis add.commute add.right_neutral less_natE)

definition zero ("[0=] _" [60] 60) where[defs]: "zero Q \<equiv> \<^bold>0 [=] Q"
lemma zero_dioph[dioph]: "is_dioph_rel ([0=] Q)"
  unfolding zero_def by (auto simp: eq_dioph)

lemma gt_dioph[dioph]: "is_dioph_rel (Q [>] R)"
  unfolding gt_def by (auto simp: lt_dioph)

lemma le_dioph[dioph]: "is_dioph_rel (Q [\<le>] R)"
  unfolding le_def by (auto simp: lt_dioph eq_dioph or_dioph)

lemma ge_dioph[dioph]: "is_dioph_rel (Q [\<ge>] R)"
  unfolding ge_def by (auto simp: gt_dioph eq_dioph or_dioph)

text \<open>Bounded Constant All Quantifier, dioph rules\<close>

lemma ALLC_LIST_dioph[dioph]: "list_all (is_dioph_rel \<circ> DF) L \<Longrightarrow> is_dioph_rel ([\<forall> in L] DF)"
  by (induction L, auto simp add: dioph)

lemma ALLC_dioph[dioph]: "\<forall>i<n. is_dioph_rel (DF i) \<Longrightarrow> is_dioph_rel ([\<forall><n] DF)"
  unfolding ALLC_def using ALLC_LIST_dioph[of DF "[0..<n]"] by (auto simp: list_all_length)

end


(*  Title:      ZF/Cardinal_AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

These results help justify infinite-branching datatypes
*)

section\<open>Cardinal Arithmetic Using AC\<close>

theory Cardinal_AC imports CardinalArith Zorn begin

subsection\<open>Strengthened Forms of Existing Theorems on Cardinals\<close>

lemma cardinal_eqpoll: "|A| \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_cardinal_eqpoll)
done

text\<open>The theorem \<^term>\<open>||A|| = |A|\<close>\<close>
lemmas cardinal_idem = cardinal_eqpoll [THEN cardinal_cong, simp]

lemma cardinal_eqE: "|X| = |Y| ==> X \<approx> Y"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cardinal_eqE, assumption+)
done

lemma cardinal_eqpoll_iff: "|X| = |Y| \<longleftrightarrow> X \<approx> Y"
by (blast intro: cardinal_cong cardinal_eqE)

lemma cardinal_disjoint_Un:
     "[| |A|=|B|;  |C|=|D|;  A \<inter> C = 0;  B \<inter> D = 0 |]
      ==> |A \<union> C| = |B \<union> D|"
by (simp add: cardinal_eqpoll_iff eqpoll_disjoint_Un)

lemma lepoll_imp_Card_le: "A \<lesssim> B ==> |A| \<le> |B|"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_lepoll_imp_Card_le, assumption)
done

lemma cadd_assoc: "(i \<oplus> j) \<oplus> k = i \<oplus> (j \<oplus> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_assoc, assumption+)
done

lemma cmult_assoc: "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cmult_assoc, assumption+)
done

lemma cadd_cmult_distrib: "(i \<oplus> j) \<otimes> k = (i \<otimes> k) \<oplus> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_cmult_distrib, assumption+)
done

lemma InfCard_square_eq: "InfCard(|A|) ==> A*A \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_InfCard_square_eq, assumption)
done

subsection \<open>The relationship between cardinality and le-pollence\<close>

lemma Card_le_imp_lepoll:
  assumes "|A| \<le> |B|" shows "A \<lesssim> B"
proof -
  have "A \<approx> |A|"
    by (rule cardinal_eqpoll [THEN eqpoll_sym])
  also have "... \<lesssim> |B|"
    by (rule le_imp_subset [THEN subset_imp_lepoll]) (rule assms)
  also have "... \<approx> B"
    by (rule cardinal_eqpoll)
  finally show ?thesis .
qed

lemma le_Card_iff: "Card(K) ==> |A| \<le> K \<longleftrightarrow> A \<lesssim> K"
apply (erule Card_cardinal_eq [THEN subst], rule iffI,
       erule Card_le_imp_lepoll)
apply (erule lepoll_imp_Card_le)
done

lemma cardinal_0_iff_0 [simp]: "|A| = 0 \<longleftrightarrow> A = 0"
apply auto
apply (drule cardinal_0 [THEN ssubst])
apply (blast intro: eqpoll_0_iff [THEN iffD1] cardinal_eqpoll_iff [THEN iffD1])
done

lemma cardinal_lt_iff_lesspoll:
  assumes i: "Ord(i)" shows "i < |A| \<longleftrightarrow> i \<prec> A"
proof
  assume "i < |A|"
  hence  "i \<prec> |A|"
    by (blast intro: lt_Card_imp_lesspoll Card_cardinal)
  also have "...  \<approx> A"
    by (rule cardinal_eqpoll)
  finally show "i \<prec> A" .
next
  assume "i \<prec> A"
  also have "...  \<approx> |A|"
    by (blast intro: cardinal_eqpoll eqpoll_sym)
  finally have "i \<prec> |A|" .
  thus  "i < |A|" using i
    by (force intro: cardinal_lt_imp_lt lesspoll_cardinal_lt)
qed

lemma cardinal_le_imp_lepoll: " i \<le> |A| ==> i \<lesssim> A"
  by (blast intro: lt_Ord Card_le_imp_lepoll Ord_cardinal_le le_trans)

subsection\<open>Other Applications of AC\<close>

lemma surj_implies_inj:
  assumes f: "f \<in> surj(X,Y)" shows "\<exists>g. g \<in> inj(Y,X)"
proof -
  from f AC_Pi [of Y "%y. f-``{y}"]
  obtain z where z: "z \<in> (\<Prod>y\<in>Y. f -`` {y})"
    by (auto simp add: surj_def) (fast dest: apply_Pair)
  show ?thesis
    proof
      show "z \<in> inj(Y, X)" using z surj_is_fun [OF f]
        by (blast dest: apply_type Pi_memberD
                  intro: apply_equality Pi_type f_imp_injective)
    qed
qed

text\<open>Kunen's Lemma 10.20\<close>
lemma surj_implies_cardinal_le:
  assumes f: "f \<in> surj(X,Y)" shows "|Y| \<le> |X|"
proof (rule lepoll_imp_Card_le)
  from f [THEN surj_implies_inj] obtain g where "g \<in> inj(Y,X)" ..
  thus "Y \<lesssim> X"
    by (auto simp add: lepoll_def)
qed

text\<open>Kunen's Lemma 10.21\<close>
lemma cardinal_UN_le:
  assumes K: "InfCard(K)"
  shows "(!!i. i\<in>K ==> |X(i)| \<le> K) ==> |\<Union>i\<in>K. X(i)| \<le> K"
proof (simp add: K InfCard_is_Card le_Card_iff)
  have [intro]: "Ord(K)" by (blast intro: InfCard_is_Card Card_is_Ord K)
  assume "!!i. i\<in>K ==> X(i) \<lesssim> K"
  hence "!!i. i\<in>K ==> \<exists>f. f \<in> inj(X(i), K)" by (simp add: lepoll_def)
  with AC_Pi obtain f where f: "f \<in> (\<Prod>i\<in>K. inj(X(i), K))"
    by force
  { fix z
    assume z: "z \<in> (\<Union>i\<in>K. X(i))"
    then obtain i where i: "i \<in> K" "Ord(i)" "z \<in> X(i)"
      by (blast intro: Ord_in_Ord [of K])
    hence "(\<mu> i. z \<in> X(i)) \<le> i" by (fast intro: Least_le)
    hence "(\<mu> i. z \<in> X(i)) < K" by (best intro: lt_trans1 ltI i)
    hence "(\<mu> i. z \<in> X(i)) \<in> K" and "z \<in> X(\<mu> i. z \<in> X(i))"
      by (auto intro: LeastI ltD i)
  } note mems = this
  have "(\<Union>i\<in>K. X(i)) \<lesssim> K \<times> K"
    proof (unfold lepoll_def)
      show "\<exists>f. f \<in> inj(\<Union>RepFun(K, X), K \<times> K)"
        apply (rule exI)
        apply (rule_tac c = "%z. \<langle>\<mu> i. z \<in> X(i), f ` (\<mu> i. z \<in> X(i)) ` z\<rangle>"
                    and d = "%\<langle>i,j\<rangle>. converse (f`i) ` j" in lam_injective)
        apply (force intro: f inj_is_fun mems apply_type Perm.left_inverse)+
        done
    qed
  also have "... \<approx> K"
    by (simp add: K InfCard_square_eq InfCard_is_Card Card_cardinal_eq)
  finally show "(\<Union>i\<in>K. X(i)) \<lesssim> K" .
qed

text\<open>The same again, using \<^term>\<open>csucc\<close>\<close>
lemma cardinal_UN_lt_csucc:
     "[| InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> |X(i)| < csucc(K) |]
      ==> |\<Union>i\<in>K. X(i)| < csucc(K)"
by (simp add: Card_lt_csucc_iff cardinal_UN_le InfCard_is_Card Card_cardinal)

text\<open>The same again, for a union of ordinals.  In use, j(i) is a bit like rank(i),
  the least ordinal j such that i:Vfrom(A,j).\<close>
lemma cardinal_UN_Ord_lt_csucc:
     "[| InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> j(i) < csucc(K) |]
      ==> (\<Union>i\<in>K. j(i)) < csucc(K)"
apply (rule cardinal_UN_lt_csucc [THEN Card_lt_imp_lt], assumption)
apply (blast intro: Ord_cardinal_le [THEN lt_trans1] elim: ltE)
apply (blast intro!: Ord_UN elim: ltE)
apply (erule InfCard_is_Card [THEN Card_is_Ord, THEN Card_csucc])
done

subsection\<open>The Main Result for Infinite-Branching Datatypes\<close>

text\<open>As above, but the index set need not be a cardinal. Work
backwards along the injection from \<^term>\<open>W\<close> into \<^term>\<open>K\<close>, given
that \<^term>\<open>W\<noteq>0\<close>.\<close>

lemma inj_UN_subset:
  assumes f: "f \<in> inj(A,B)" and a: "a \<in> A"
  shows "(\<Union>x\<in>A. C(x)) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))"
proof (rule UN_least)
  fix x
  assume x: "x \<in> A"
  hence fx: "f ` x \<in> B" by (blast intro: f inj_is_fun [THEN apply_type])
  have "C(x) \<subseteq> C(if f ` x \<in> range(f) then converse(f) ` (f ` x) else a)"
    using f x by (simp add: inj_is_fun [THEN apply_rangeI])
  also have "... \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f) ` y else a))"
    by (rule UN_upper [OF fx])
  finally show "C(x) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))" .
qed

theorem le_UN_Ord_lt_csucc:
  assumes IK: "InfCard(K)" and WK: "|W| \<le> K" and j: "\<And>w. w\<in>W \<Longrightarrow> j(w) < csucc(K)"
  shows "(\<Union>w\<in>W. j(w)) < csucc(K)"
proof -
  have CK: "Card(K)"
    by (simp add: InfCard_is_Card IK)
  then obtain f where f: "f \<in> inj(W, K)" using WK
    by(auto simp add: le_Card_iff lepoll_def)
  have OU: "Ord(\<Union>w\<in>W. j(w))" using j
    by (blast elim: ltE)
  note lt_subset_trans [OF _ _ OU, trans]
  show ?thesis
    proof (cases "W=0")
      case True  \<comment> \<open>solve the easy 0 case\<close>
      thus ?thesis by (simp add: CK Card_is_Ord Card_csucc Ord_0_lt_csucc)
    next
      case False
        then obtain x where x: "x \<in> W" by blast
        have "(\<Union>x\<in>W. j(x)) \<subseteq> (\<Union>k\<in>K. j(if k \<in> range(f) then converse(f) ` k else x))"
          by (rule inj_UN_subset [OF f x])
        also have "... < csucc(K)" using IK
          proof (rule cardinal_UN_Ord_lt_csucc)
            fix k
            assume "k \<in> K"
            thus "j(if k \<in> range(f) then converse(f) ` k else x) < csucc(K)" using f x j
              by (simp add: inj_converse_fun [THEN apply_type])
          qed
        finally show ?thesis .
    qed
qed

end


(* Title: Set_Multiset_Extras.thy
   Author: Chelsea Edmonds
*)

section \<open>Micellaneous Multset/Set Extras \<close>

theory Set_Multiset_Extras imports Design_Theory.Multisets_Extras "HOL-Combinatorics.Multiset_Permutations"
begin

subsection \<open> Set extras \<close>
text \<open> Minor set extras on cardinality and filtering \<close>
lemma equal_card_inter_fin_eq_sets: "finite A \<Longrightarrow> finite B \<Longrightarrow> card A = card B \<Longrightarrow>
  card (A \<inter> B) = card A \<Longrightarrow> A = B"
  by (metis Int_lower1 Int_lower2 card_subset_eq)

lemma insert_filter_set_true: "P x \<Longrightarrow> {a \<in> (insert x A) . P a} = insert x {a \<in> A . P a}"
  by auto

lemma insert_filter_set_false: "\<not> P x \<Longrightarrow> {a \<in> (insert x A) . P a} = {a \<in> A . P a}"
  by auto

subsection \<open>Multiset Extras \<close>
text \<open> Minor multiset extras on size and element reasoning \<close>

lemma obtain_two_items_mset:
  assumes "size A > 1"
  obtains x y where "x \<in># A" and "y \<in># A - {#x#}"
proof -
  obtain x where "x \<in># A"
    by (metis assms gr_implies_not_zero multiset_nonemptyE size_empty)
  have "size (A - {#x#}) > 0"
    by (metis \<open>x \<in># A\<close> assms insert_DiffM less_irrefl_nat nonempty_has_size size_single)
  then obtain bl2 where "bl2 \<in># A - {#x#}"
    by (metis less_not_refl multiset_nonemptyE size_empty)
  thus ?thesis
    using \<open>x \<in># A\<close> that by blast
qed

lemma obtain_two_items_mset_filter:
  assumes "size {#a \<in># A . P a #} > 1"
  obtains x y where "x \<in># A" and "y \<in># A - {#x#}" and "P x" and "P y"
proof -
  obtain x y where xin: "x \<in># {#a \<in># A . P a #}" and yin: "y \<in># {#a \<in># A . P a #} - {#x#}"
    using obtain_two_items_mset assms by blast
  then have xdets: "x \<in># A" "P x" by auto
  then have yin2: "y \<in># {#a \<in># (A - {#x#}) . P a #}" using yin
    by force
  then have "y \<in># (A - {#x#})" "P y"
    by (metis multiset_partition union_iff) (meson yin2 filter_mset_eq_conv)
  thus ?thesis using xdets that by blast
qed

lemma size_count_mset_ss:
  assumes "finite B"
  assumes "(set_mset A) \<subseteq> B"
  shows "size A = (\<Sum> x \<in> B . count A x)"
proof -
  obtain C where cdef: "B - (set_mset A) = C" using assms
    by simp
  have fin: "finite (set_mset A)" using assms by auto
  have un: "C \<union> (set_mset A) = B"
    using Diff_partition \<open>B - set_mset A = C\<close> assms by blast
  have disj: "C \<inter> (set_mset A) = {}"
    using \<open>B - set_mset A = C\<close> by auto
  have zero: "\<And> x . x\<in> C \<Longrightarrow> count A x = 0"
    by (meson count_eq_zero_iff disj disjoint_iff_not_equal)
  then have "(\<Sum> x \<in> B . count A x) = (\<Sum> x \<in> (C \<union> set_mset A) . count A x)" using un by simp
  also have "... = (\<Sum> x \<in> C . count A x) + (\<Sum> x \<in> (set_mset A) . count A x) "
    using disj fin assms cdef sum.subset_diff by (metis un)
  also have "... = (\<Sum> x \<in> (set_mset A) . count A x)" using zero by auto
  finally have "(\<Sum> x \<in> B . count A x) = size A"
    by (simp add: size_multiset_overloaded_eq)
  thus ?thesis by simp
qed

lemma mset_list_by_index: "mset (xs) = image_mset (\<lambda> i . (xs ! i)) (mset_set {..<length xs})"
  by (metis map_nth mset_map mset_set_upto_eq_mset_upto)

lemma count_mset_split_image_filter:
  assumes "\<And> x. x \<in>#A \<Longrightarrow> a \<noteq> g x"
  shows "count (image_mset (\<lambda>x. if P x then a else g x) A ) a = size (filter_mset P A)"
  using image_mset_If image_mset_filter_swap size_image_mset
  by (smt (verit) assms count_size_set_repr filter_mset_cong)

lemma count_mset_split_image_filter_not:
  assumes "\<And> x. x \<in>#A \<Longrightarrow> b \<noteq> f x"
  shows "count (image_mset (\<lambda>x. if P x then f x else b) A ) b = size (filter_mset (\<lambda> x. \<not> P x) A)"
  using image_mset_If image_mset_filter_swap size_image_mset
  by (smt (verit) assms count_size_set_repr filter_mset_cong)

lemma removeAll_size_lt: "size (removeAll_mset C M) \<le> size M"
  by (simp add: size_mset_mono)

lemma mset_image_eq_filter_eq: "A = image_mset f B \<Longrightarrow>
  filter_mset P A = (image_mset f (filter_mset (\<lambda> x. P (f x)) B))"
  by (simp add: filter_mset_image_mset)

subsection \<open>Permutation on Sets and Multisets \<close>

lemma elem_permutation_of_set_empty_iff: "finite A \<Longrightarrow> xs \<in> permutations_of_set A \<Longrightarrow>
    xs = [] \<longleftrightarrow> A = {}"
  using permutations_of_setD(1) by fastforce

lemma elem_permutation_of_mset_empty_iff: "xs \<in> permutations_of_multiset A \<Longrightarrow> xs = [] \<longleftrightarrow> A = {#}"
  using permutations_of_multisetD by fastforce

subsection \<open> Lists \<close>
text \<open>Further lemmas on the relationship between lists and multisets \<close>

lemma count_distinct_mset_list_index: "i1 < length xs \<Longrightarrow> i2 < length xs \<Longrightarrow> i1 \<noteq> i2 \<Longrightarrow>
    distinct_mset (mset xs) \<Longrightarrow> xs ! i1 \<noteq> xs ! i2"
  by (simp add:  nth_eq_iff_index_eq)

lemma index_remove1_mset_ne:
  assumes "x \<in># (mset xs)"
  assumes "y \<in># remove1_mset x (mset xs)"
  assumes "xs ! j1 = x"
  assumes "j1 < length xs"
  obtains j2 where "xs ! j2 = y" and "j2 < length xs" and "j1 \<noteq> j2"
proof (cases "x = y")
  case True
  then have "count (mset xs) x \<ge> 2"
    using assms(2) count_eq_zero_iff by fastforce
  then have crm: "count (remove1_mset x (mset xs)) x \<ge> 1"
    by (metis True assms(2) count_greater_eq_one_iff)
  obtain ys zs where xseq: "xs = ys @ (x # zs)" and yseq: "ys = take j1 xs" and zseq: "zs = drop (Suc j1) xs"
    using  assms(1) assms(3) id_take_nth_drop in_mset_conv_nth assms(4) by blast
  have "mset xs = mset ys + mset (x # zs)"
    by (simp add: xseq)
  then have "remove1_mset x (mset xs) = mset (ys) + mset (zs)"
    using assms by simp
  then have "y \<in># (mset ys + mset zs)" using crm
    using True \<open>remove1_mset x (mset xs) = mset ys + mset zs\<close> assms(2) by presburger
  then have yinor: "y \<in># mset ys \<or> y \<in># mset zs" by simp
  then show ?thesis proof (cases "y \<in># mset ys")
    case True
    then obtain j2 where yeq: "ys ! j2 = y" and j2lt: "j2 < length ys"
      by (meson in_mset_conv_nth)
    then have 1: "xs ! j2 = y" using yseq by simp
    have "j2 < j1" using yseq j2lt by simp
    then show ?thesis using that 1 j2lt xseq by simp
  next
    case False
    then have "y \<in># mset zs" using yinor by simp
    then obtain j2 where zsy: "zs ! j2 = y" and j2lt: "j2 < length zs"
      by (meson in_mset_conv_nth)
    then have 1: "xs ! ((Suc j1) + j2) = y" using zseq zsy assms(4) by simp
    have "length xs = (Suc j1) + length zs" using zseq xseq
      by (metis Suc_diff_Suc add_Suc_shift add_diff_inverse_nat assms(4) length_drop less_imp_not_less)
    then have 2: "(Suc j1) + j2 < length xs" using j2lt by simp
    then show ?thesis using 1 that by simp
  qed
next
  case False
  then show ?thesis
    by (metis that assms(2) assms(3) in_diffD in_mset_conv_nth)
qed

lemma count_list_mset: "count_list xs x = count (mset xs) x"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case proof (cases "a = x")
    case True
    have mset_add_split: "count (mset (a # xs)) x = count (add_mset a (mset xs)) x"
      by simp
    then have "count (mset (a # xs)) x = count (mset xs) x + 1"
      by (metis True Suc_eq_plus1 count_add_mset)
    then show ?thesis using True Cons.hyps by simp
  next
    case False
    then show ?thesis using Cons.hyps by simp
  qed
qed

lemma count_min_2_indices_lt:
  assumes "i1 < i2"
  assumes "xs ! i1 = x"
  assumes "xs ! i2 = x"
  assumes "i1 < length xs" "i2 < length xs"
  shows "count (mset xs) x \<ge> 2"
proof -
  obtain xs1 xs2 where xse: "xs = xs1 @ xs2" and xs1: "xs1 = take i2 xs" and xs2: "xs2 = drop i2 xs"
    by simp
  have "i1 < length xs1" using assms length_take
    by (simp add: assms(4) \<open>xs1 = take i2 xs\<close>)
  then have xs1in:  "xs ! i1 \<in># mset xs1"
    by (simp add: nth_append xse)
  have "i2 \<ge> length xs1" using assms length_take xs1 by simp
  then have xs2in: "xs ! i2 \<in># mset xs2" using xse nth_append
    by (metis (no_types, lifting) assms(5) in_mset_conv_nth leD leI take_all_iff take_append)
  have "count (mset xs) x = count ((mset xs1) + (mset xs2)) x"
    by (simp add: xse)
  then have "count (mset xs) x = count (mset xs1) x + count (mset xs2) x" by simp
  thus ?thesis using xs1in xs2in
    by (metis add_mono assms(2) assms(3) count_greater_eq_one_iff nat_1_add_1)
qed

lemma count_min_2_indices: "i1 \<noteq> i2 \<Longrightarrow> xs ! i1 = x \<Longrightarrow> xs ! i2 = x \<Longrightarrow> i1 < length xs \<Longrightarrow>
  i2 < length xs \<Longrightarrow> count (mset xs) x \<ge> 2"
  apply (cases "i1 < i2", simp add: count_min_2_indices_lt)
  by (metis count_min_2_indices_lt linorder_cases)

lemma obtain_set_list_item:
  assumes "x \<in> set xs"
  obtains i where "i < length xs" and "xs ! i = x"
  by (meson assms in_set_conv_nth)

subsection \<open>Summation Rules\<close>

text \<open> Some lemmas to make it simpler to work with double and triple summations \<close>
context comm_monoid_add
begin

lemma sum_reorder_triple: "(\<Sum> l \<in> A . (\<Sum> i \<in> B . (\<Sum> j \<in> C . g l i j))) =
  (\<Sum> i \<in> B . (\<Sum> j \<in> C . (\<Sum> l \<in> A . g l i j)))"
proof -
  have "(\<Sum> l \<in> A . (\<Sum> i \<in> B . (\<Sum> j \<in> C . g l i j))) = (\<Sum>i \<in> B . (\<Sum> l \<in> A  . (\<Sum> j \<in> C . g l i j)))"
    using sum.swap[of "(\<lambda> l i . (\<Sum> j \<in> C . g l i j))" "B" "A"] by simp
  also have "...  = (\<Sum>i \<in> B . (\<Sum> j \<in> C . (\<Sum>l \<in> A . g l i j)))" using sum.swap by metis
  finally show ?thesis by simp
qed

lemma double_sum_mult_hom:
  fixes k :: "'b :: {comm_ring_1}"
  shows "(\<Sum> i \<in> A . (\<Sum> j \<in> g i . k * (f i j))) = k* (\<Sum> i \<in> A . (\<Sum> j \<in> g i . f i j))"
  by (metis (mono_tags, lifting) comm_monoid_add_class.sum.cong sum_distrib_left)

lemma double_sum_split_case:
  assumes "finite A"
  shows "(\<Sum> i \<in> A . (\<Sum> j \<in> A . f i j)) = (\<Sum> i \<in> A . (f i i)) + (\<Sum> i \<in> A . (\<Sum> j \<in> (A - {i}) . f i j))"
proof -
  have "\<And> i. i \<in> A \<Longrightarrow> (\<Sum> j \<in> A . f i j) = f i i + (\<Sum> j \<in> (A - {i}) . f i j)"
    using sum.remove assms by metis
  then show ?thesis by (simp add: sum.distrib)
qed

lemma double_sum_split_case2: "(\<Sum> i \<in> A . (\<Sum> j \<in> A . g i j)) =
  (\<Sum> i \<in> A . (g i i)) + (\<Sum> i \<in> A . (\<Sum> j \<in> {a \<in> A . a \<noteq> i} . g i j)) "
proof -
  have "\<And> i. A = {a \<in> A . a = i} \<union> {a \<in> A . a \<noteq> i}" by auto
  then have part: "\<And> i. i \<in> A \<Longrightarrow> A = {i} \<union> {a \<in> A . a \<noteq> i}" by auto
  have empt:"\<And> i. {i} \<inter> {a \<in> A . a \<noteq> i} = {}"
    by simp
  then have "(\<Sum> i \<in> A . (\<Sum> j \<in> A . g i j)) =
    (\<Sum> i \<in> A . ((\<Sum> j \<in> {i} . g i j) + (\<Sum> j \<in> {a \<in> A . a \<noteq> i} . g i j)))" using part
    by (smt (verit) finite_Un local.sum.cong local.sum.infinite local.sum.union_disjoint)
  also have "... = (\<Sum> i \<in> A . ((\<Sum> j \<in> {i} . g i j))) + (\<Sum> i \<in> A . (\<Sum> j \<in> {a \<in> A . a \<noteq> i} . g i j))"
    by (simp add: local.sum.distrib)
  finally show ?thesis by simp
qed

end

context comm_ring_1
begin

lemma double_sum_split_case_square:
  assumes "finite A"
  shows "(\<Sum> i \<in> A . f i )^2 = (\<Sum> i \<in> A . (f i * f i)) + (\<Sum> i \<in> A . (\<Sum> j \<in> (A - {i}) . f i * f j))"
proof -
  have "(\<Sum> i \<in> A . f i )^2 = (\<Sum> i \<in> A . f i) * (\<Sum> i \<in> A . f i)"
    using power2_eq_square by blast
  then have "(\<Sum> i \<in> A . f i) * (\<Sum> i \<in> A . f i) = (\<Sum> i \<in> A . f i) * (\<Sum> j \<in> A . f j)" by simp
  also have 1: "... = (\<Sum> i \<in> A . f i * (\<Sum> j \<in> A . f j))" using sum_distrib_right by simp
  also have 2: "... = (\<Sum> i \<in> A .  (\<Sum> j \<in> A . f i * f j))" using sum_distrib_left by metis
  finally have "(\<Sum> i \<in> A . f i) * (\<Sum> i \<in> A . f i) =
    (\<Sum> i \<in> A . (f i * f i)) + (\<Sum> i \<in> A . (\<Sum> j \<in> (A - {i}) . f i * f j))"
    using assms double_sum_split_case[of "A" "\<lambda> i j . f i * f j"] 1 2 by presburger
  then show ?thesis
    using power2_eq_square by presburger
qed

lemma double_sum_split_square_diff:  "finite {0..<x} \<Longrightarrow>
  (\<Sum> i \<in> {0..<x} . (\<Sum> j \<in> ({0..< x} - {i}) . c i * c j)) =
  (\<Sum> i \<in> {0..<x} . c i)^2 - (\<Sum> i \<in> {0..<x} . c i * c i)"
  using double_sum_split_case_square[of "{0..<x}" "\<lambda> i. c i"] by fastforce

end
end


(*  Title:      The Jordan-Hölder Theorem
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory JordanHolder
imports
  CompositionSeries
  MaximalNormalSubgroups
  "HOL-Library.Multiset"
  GroupIsoClasses
begin

section \<open>The Jordan-H\"older Theorem\<close>

locale jordan_hoelder = group
  + comp\<HH>?: composition_series G \<HH>
  + comp\<GG>?: composition_series G \<GG> for \<HH> and \<GG>
  + assumes finite:"finite (carrier G)"

text \<open>Before we finally start the actual proof of the theorem, one last lemma: Cancelling
  the last entry of a normal series results in a normal series with quotients being all but the last
  of the original ones.\<close>

lemma (in normal_series) quotients_butlast:
  assumes "length \<GG> > 1"
  shows "butlast quotients = normal_series.quotients (G\<lparr>carrier := \<GG> ! (length \<GG> - 1 - 1)\<rparr>) (take (length \<GG> - 1) \<GG>)"
proof (rule nth_equalityI )
  define n where "n = length \<GG> - 1"
  hence "n = length (take n \<GG>)" "n > 0" "n < length \<GG>" using assms notempty by auto
  interpret normal\<GG>butlast: normal_series "(G\<lparr>carrier := \<GG> ! (n - 1)\<rparr>)" "take n \<GG>"
    using normal_series_prefix_closed \<open>n > 0\<close> \<open>n < length \<GG>\<close> by auto
  have "length (butlast quotients) = length quotients - 1" by (metis length_butlast)
  also have "\<dots> = length \<GG> - 1 - 1" by (metis add_diff_cancel_right' quotients_length)
  also have "\<dots> = length (take n \<GG>) - 1" by (metis \<open>n = length (take n \<GG>)\<close> n_def)
  also have "\<dots> = length normal\<GG>butlast.quotients" by (metis normal\<GG>butlast.quotients_length diff_add_inverse2)
  finally show "length (butlast quotients) = length normal\<GG>butlast.quotients" .
  have "\<forall>i<length (butlast quotients). butlast quotients ! i = normal\<GG>butlast.quotients ! i"
  proof auto
    fix i
    assume i:"i < length quotients - Suc 0"
    hence i':"i < length \<GG> - 1" "i < n" "i + 1 < n" unfolding n_def using quotients_length by auto
    from i have "butlast quotients ! i = quotients ! i" by (metis One_nat_def length_butlast nth_butlast)
    also have "\<dots> = G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i" unfolding quotients_def using i'(1) by auto
    also have "\<dots> = G\<lparr>carrier := (take n \<GG>) ! (i + 1)\<rparr> Mod (take n \<GG>) ! i" using i'(2,3) nth_take by metis
    also have "\<dots> = normal\<GG>butlast.quotients ! i" unfolding normal\<GG>butlast.quotients_def using i' by fastforce
    finally show "butlast (normal_series.quotients G \<GG>) ! i = normal_series.quotients (G\<lparr>carrier := \<GG> ! (n - Suc 0)\<rparr>) (take n \<GG>) ! i" by auto
  qed
  thus "\<And>i. i < length (butlast quotients)
            \<Longrightarrow> butlast quotients ! i
              = normal_series.quotients (G\<lparr>carrier := \<GG> ! (length \<GG> - 1 - 1)\<rparr>)  (take (length \<GG> - 1) \<GG>) ! i"
    unfolding n_def by auto
qed

text \<open>The main part of the Jordan Hölder theorem is its statement about the uniqueness of
  a composition series. Here, uniqueness up to reordering and isomorphism is modelled by stating
  that the multisets of isomorphism classes of all quotients are equal.\<close>

theorem jordan_hoelder_multisets:
  assumes "group G"
  assumes "finite (carrier G)"
  assumes "composition_series G \<GG>"
  assumes "composition_series G \<HH>"
  shows "mset (map group.iso_class (normal_series.quotients G \<GG>))
    = mset (map group.iso_class (normal_series.quotients G \<HH>))"
using assms
proof (induction "length \<GG>" arbitrary: \<GG> \<HH> G rule: full_nat_induct)
  case (1 \<GG> \<HH> G)
  then interpret comp\<GG>: composition_series G \<GG> by simp
  from 1 interpret comp\<HH>: composition_series G \<HH> by simp
  from 1 interpret grpG: group G by simp
  show ?case
  proof (cases "length \<GG> \<le> 2")
  next
    case True
    hence  "length \<GG> = 0 \<or> length \<GG> = 1 \<or> length \<GG> = 2" by arith
    with comp\<GG>.notempty have  "length \<GG> = 1 \<or> length \<GG> = 2" by simp
    thus ?thesis
    proof (auto simp del: mset_map)
      \<comment> \<open>First trivial case: @{text \<GG>} is the trivial group.\<close>
      assume "length \<GG> = Suc 0"
      hence length:"length \<GG> = 1" by simp
      hence "length [] + 1 = length \<GG>" by auto
      moreover from length have char\<GG>:"\<GG> = [{\<one>\<^bsub>G\<^esub>}]" by (metis comp\<GG>.composition_series_length_one)
      hence "carrier G = {\<one>\<^bsub>G\<^esub>}" by (metis comp\<GG>.composition_series_triv_group)
      with length char\<GG> have "\<GG> = \<HH>" using comp\<HH>.composition_series_triv_group by simp
      thus ?thesis by simp
    next
      \<comment> \<open>Second trivial case: @{text \<GG>} is simple.\<close>
      assume "length \<GG> = 2"
      hence \<GG>char:"\<GG> = [{\<one>\<^bsub>G\<^esub>}, carrier G]" by (metis comp\<GG>.length_two_unique)
      hence simple:"simple_group G" by (metis comp\<GG>.composition_series_simple_group)
      hence "\<HH> = [{\<one>\<^bsub>G\<^esub>}, carrier G]" using comp\<HH>.composition_series_simple_group by auto
      with \<GG>char have "\<GG> = \<HH>" by simp
      thus ?thesis by simp
    qed
  next
    case False
    \<comment> \<open>Non-trivial case: @{text \<GG>} has length at least 3.\<close>
    hence length:"length \<GG> \<ge> 3" by simp
    \<comment> \<open>First we show that @{text \<HH>} must have a length of at least 3.\<close>
    hence "\<not> simple_group G" using comp\<GG>.composition_series_simple_group by auto
    hence "\<HH> \<noteq> [{\<one>\<^bsub>G\<^esub>}, carrier G]" using comp\<HH>.composition_series_simple_group by auto
    hence "length \<HH> \<noteq> 2" using comp\<HH>.length_two_unique by auto
    moreover from length have "carrier G \<noteq> {\<one>\<^bsub>G\<^esub>}" using comp\<GG>.composition_series_length_one comp\<GG>.composition_series_triv_group by auto
    hence "length \<HH> \<noteq> 1" using comp\<HH>.composition_series_length_one comp\<HH>.composition_series_triv_group by auto
    moreover from comp\<HH>.notempty have "length \<HH> \<noteq> 0" by simp
    ultimately have length\<HH>big:"length \<HH> \<ge> 3" using comp\<HH>.notempty by arith
    define m where "m = length \<HH> - 1"
    define n where "n = length \<GG> - 1"
    from length\<HH>big have m':"m > 0" "m < length \<HH>" "(m - 1) + 1 < length \<HH>" "m - 1 = length \<HH> - 2" "m - 1 + 1 = length \<HH> - 1" "m - 1 < length \<HH>"
      unfolding m_def by auto
    from length have n':"n > 0" "n < length \<GG>" "(n - 1) + 1 < length \<GG>" "n - 1 < length \<GG>" "Suc n \<le> length \<GG>"
     "n - 1 = length \<GG> - 2" "n - 1 + 1 = length \<GG> - 1"  unfolding n_def by auto
    define \<GG>Pn where "\<GG>Pn = G\<lparr>carrier := \<GG> ! (n - 1)\<rparr>"
    define \<HH>Pm where "\<HH>Pm = G\<lparr>carrier := \<HH> ! (m - 1)\<rparr>"
    then interpret grp\<GG>Pn: group \<GG>Pn unfolding \<GG>Pn_def using n' by (metis comp\<GG>.normal_series_subgroups comp\<GG>.subgroup_imp_group)
    interpret grp\<HH>Pm: group \<HH>Pm unfolding \<HH>Pm_def using m' comp\<HH>.normal_series_subgroups 1(2) group.subgroup_imp_group by force
    have finGbl:"finite (carrier \<GG>Pn)" using \<open>n - 1 < length \<GG>\<close> 1(3) unfolding \<GG>Pn_def using comp\<GG>.normal_series_subgroups comp\<GG>.subgroup_finite by auto
    have finHbl:"finite (carrier \<HH>Pm)" using \<open>m - 1 < length \<HH>\<close> 1(3) unfolding \<HH>Pm_def using comp\<HH>.normal_series_subgroups comp\<GG>.subgroup_finite by auto
    have quots\<GG>notempty:"comp\<GG>.quotients \<noteq> []" using comp\<GG>.quotients_length length by auto
    have quots\<HH>notempty:"comp\<HH>.quotients \<noteq> []" using comp\<HH>.quotients_length length\<HH>big by auto

    \<comment> \<open>Instantiate truncated composition series since they are used for both cases\<close>
    interpret \<HH>butlast: composition_series \<HH>Pm "take m \<HH>" using comp\<HH>.composition_series_prefix_closed m'(1,2) \<HH>Pm_def by auto
    interpret \<GG>butlast: composition_series \<GG>Pn "take n \<GG>" using comp\<GG>.composition_series_prefix_closed n'(1,2) \<GG>Pn_def by auto
    have ltaken:"n = length (take n \<GG>)" using length_take n'(2) by auto
    have ltakem:"m = length (take m \<HH>)" using length_take m'(2) by auto
    show ?thesis
    proof (cases "\<HH> ! (m - 1)  = \<GG> ! (n - 1)")
      \<comment> \<open>If @{term "\<HH> ! (l - 1) = \<GG> ! 1"}, everything is simple...\<close>
      case True
      \<comment> \<open>The last quotients of @{term \<GG>} and @{term \<HH>} are equal.\<close>
      have lasteq:"last comp\<GG>.quotients = last comp\<HH>.quotients"
      proof -
        from length have lg:"length \<GG> - 1 - 1 + 1 = length \<GG> - 1" by (metis Suc_diff_1 Suc_eq_plus1 n'(1) n_def)
        from length\<HH>big have lh:"length \<HH> - 1 - 1 + 1 = length \<HH> - 1" by (metis Suc_diff_1 Suc_eq_plus1 \<open>0 < m\<close> m_def)
        have "last comp\<GG>.quotients =  G Mod \<GG> ! (n - 1)" using length comp\<GG>.last_quotient unfolding n_def by auto
        also have "\<dots> = G Mod \<HH> ! (m - 1)" using True by simp
        also have "\<dots> = last comp\<HH>.quotients" using length\<HH>big comp\<HH>.last_quotient unfolding m_def by auto
        finally show ?thesis .
      qed
      from ltaken have ind:"mset (map group.iso_class \<GG>butlast.quotients) = mset (map group.iso_class \<HH>butlast.quotients)"
        using 1(1) True n'(5) grp\<GG>Pn.is_group finGbl \<GG>butlast.is_composition_series \<HH>butlast.is_composition_series unfolding \<GG>Pn_def \<HH>Pm_def by metis
      have "mset (map group.iso_class comp\<GG>.quotients)
                    = mset (map group.iso_class (butlast comp\<GG>.quotients @ [last comp\<GG>.quotients]))" by (simp add: quots\<GG>notempty)
      also have "\<dots> = mset (map group.iso_class (\<GG>butlast.quotients @ [last (comp\<GG>.quotients)]))" using comp\<GG>.quotients_butlast length unfolding n_def \<GG>Pn_def by auto
      also have "\<dots> = mset ((map group.iso_class \<GG>butlast.quotients) @ [group.iso_class (last (comp\<GG>.quotients))])" by auto
      also have "\<dots> = mset (map group.iso_class \<GG>butlast.quotients) + {# group.iso_class (last (comp\<GG>.quotients)) #}" by auto
      also have "\<dots> = mset (map group.iso_class \<HH>butlast.quotients) + {# group.iso_class (last (comp\<GG>.quotients)) #}" using ind by simp
      also have "\<dots> = mset (map group.iso_class \<HH>butlast.quotients) + {# group.iso_class (last (comp\<HH>.quotients)) #}" using lasteq by simp
      also have "\<dots> = mset ((map group.iso_class \<HH>butlast.quotients) @ [group.iso_class (last (comp\<HH>.quotients))])" by auto
      also have "\<dots> = mset (map group.iso_class (\<HH>butlast.quotients @ [last (comp\<HH>.quotients)]))" by auto
      also have "\<dots> = mset (map group.iso_class (butlast comp\<HH>.quotients @ [last comp\<HH>.quotients]))" using length\<HH>big comp\<HH>.quotients_butlast unfolding m_def \<HH>Pm_def by auto
      also have "\<dots> = mset (map group.iso_class comp\<HH>.quotients)" using append_butlast_last_id quots\<HH>notempty by simp
      finally show ?thesis .
    next
      case False
      define \<HH>PmInt\<GG>Pn where "\<HH>PmInt\<GG>Pn = G\<lparr>carrier := \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)\<rparr>"
      interpret \<GG>Pnmax: max_normal_subgroup "\<GG> ! (n - 1)" G unfolding n_def
        by (metis add_lessD1 diff_diff_add n'(3) add.commute one_add_one 1(3) comp\<GG>.snd_to_last_max_normal)
      interpret \<HH>Pmmax: max_normal_subgroup "\<HH> ! (m - 1)" G unfolding m_def
        by (metis add_lessD1 diff_diff_add m'(3) add.commute one_add_one 1(3) comp\<HH>.snd_to_last_max_normal)
      have \<HH>PmnormG:"\<HH> ! (m - 1) \<lhd> G" using comp\<HH>.normal_series_snd_to_last m'(4) unfolding m_def by auto
      have \<GG>PnnormG:"\<GG> ! (n - 1) \<lhd> G" using comp\<GG>.normal_series_snd_to_last n'(6) unfolding n_def by auto
      have \<HH>Pmint\<GG>PnnormG:"\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) \<lhd> G" using \<HH>PmnormG \<GG>PnnormG by (rule comp\<GG>.normal_subgroup_intersect)
      have Intnorm\<GG>Pn:"\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) \<lhd> \<GG>Pn" using \<GG>PnnormG \<HH>PmnormG Int_lower2 unfolding \<GG>Pn_def
        by (metis comp\<GG>.normal_restrict_supergroup comp\<GG>.normal_series_subgroups comp\<GG>.normal_subgroup_intersect n'(4))
      then interpret grp\<GG>PnMod\<HH>Pmint\<GG>Pn: group "\<GG>Pn Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)" by (rule normal.factorgroup_is_group)
      have Intnorm\<HH>Pm:"\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) \<lhd> \<HH>Pm" using \<HH>PmnormG \<GG>PnnormG Int_lower2 Int_commute unfolding \<HH>Pm_def
        by (metis comp\<GG>.normal_restrict_supergroup comp\<GG>.normal_subgroup_intersect comp\<HH>.normal_series_subgroups m'(6))
      then interpret grp\<HH>PmMod\<HH>Pmint\<GG>Pn: group "\<HH>Pm Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)" by (rule normal.factorgroup_is_group)

      \<comment> \<open>Show that the second to last entries are not contained in each other.\<close>
      have not\<HH>PmSub\<GG>Pn:"\<not> (\<HH> ! (m - 1) \<subseteq> \<GG> ! (n - 1))" using \<HH>Pmmax.max_normal \<GG>PnnormG False[symmetric] \<GG>Pnmax.proper by simp
      have not\<GG>PnSub\<HH>Pm:"\<not> (\<GG> ! (n - 1) \<subseteq> \<HH> ! (m - 1))" using \<GG>Pnmax.max_normal \<HH>PmnormG False \<HH>Pmmax.proper by simp

      \<comment> \<open>Show that @{term "G Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1))"} is a simple group.\<close>
      have \<HH>PmSubSetmult:"\<HH> ! (m - 1) \<subseteq> \<HH> ! (m - 1) <#>\<^bsub>G\<^esub> \<GG> ! (n - 1)"
        using second_isomorphism_grp.H_contained_in_set_mult \<GG>Pnmax.is_normal \<HH>PmnormG normal_imp_subgroup
        unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def max_normal_subgroup_def by metis
      have \<GG>PnSubSetmult:"\<GG> ! (n - 1) \<subseteq> \<HH> ! (m - 1) <#>\<^bsub>G\<^esub> \<GG> ! (n - 1)"
        using second_isomorphism_grp.S_contained_in_set_mult \<GG>Pnmax.is_normal \<HH>PmnormG normal_imp_subgroup
        unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def max_normal_subgroup_def by metis
      have "\<GG> ! (n - 1) \<noteq> (\<HH> ! (m - 1)) <#>\<^bsub>G\<^esub> (\<GG> ! (n - 1))" using \<HH>PmSubSetmult not\<HH>PmSub\<GG>Pn by auto
      hence set_multG:"(\<HH> ! (m - 1)) <#>\<^bsub>G\<^esub> (\<GG> ! (n - 1)) = carrier G"
        using \<GG>Pnmax.max_normal \<GG>Pnmax.is_normal \<HH>PmnormG comp\<GG>.normal_subgroup_set_mult_closed \<GG>PnSubSetmult by metis
      then obtain \<phi> where "\<phi> \<in> iso (\<GG>Pn Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1))) (G\<lparr>carrier := carrier G\<rparr> Mod \<HH> ! (m - 1))"
        using second_isomorphism_grp.normal_intersection_quotient_isom \<HH>PmnormG \<GG>Pnmax.is_normal normal_imp_subgroup
        unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def max_normal_subgroup_def \<GG>Pn_def by metis
      hence \<phi>:"\<phi> \<in> iso (\<GG>Pn Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1))) (G Mod \<HH> ! (m - 1))" by auto
      then obtain \<phi>2 where \<phi>2:"\<phi>2 \<in> iso (G Mod \<HH> ! (m - 1)) (\<GG>Pn Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)))"
        using group.iso_set_sym grp\<GG>PnMod\<HH>Pmint\<GG>Pn.is_group by auto
      moreover have "simple_group (G\<lparr>carrier := \<HH> ! (m - 1 + 1)\<rparr> Mod \<HH> ! (m - 1))" using comp\<HH>.simplefact m'(3) by simp
      hence "simple_group (G Mod \<HH> ! (m - 1))" using comp\<HH>.last last_conv_nth comp\<HH>.notempty m'(5) by fastforce
      ultimately have simple\<GG>PnModInt:"simple_group (\<GG>Pn Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)))"
        using simple_group.iso_simple grp\<GG>PnMod\<HH>Pmint\<GG>Pn.is_group by auto
      interpret grpGMod\<HH>Pm: group "(G Mod \<HH> ! (m - 1))" by (metis \<HH>PmnormG normal.factorgroup_is_group)

      \<comment> \<open>Show analogues of the previous statements for @{term "\<HH> ! (m - 1)"} instead of @{term "\<GG> ! (n - 1)"}.\<close>
      have \<HH>PmSubSetmult':"\<HH> ! (m - 1) \<subseteq> \<GG> ! (n - 1) <#>\<^bsub>G\<^esub> \<HH> ! (m - 1)"
        using second_isomorphism_grp.S_contained_in_set_mult \<GG>Pnmax.is_normal \<HH>PmnormG normal_imp_subgroup
        unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def max_normal_subgroup_def by metis
      have \<GG>PnSubSetmult':"\<GG> ! (n - 1) \<subseteq> \<GG> ! (n - 1) <#>\<^bsub>G\<^esub> \<HH> ! (m - 1)"
        using second_isomorphism_grp.H_contained_in_set_mult \<GG>Pnmax.is_normal \<HH>PmnormG normal_imp_subgroup
        unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def max_normal_subgroup_def by metis
      have "\<HH> ! (m - 1) \<noteq> (\<GG> ! (n - 1)) <#>\<^bsub>G\<^esub> (\<HH> ! (m - 1))" using \<GG>PnSubSetmult' not\<GG>PnSub\<HH>Pm by auto
      hence set_multG:"(\<GG> ! (n - 1)) <#>\<^bsub>G\<^esub> (\<HH> ! (m - 1)) = carrier G"
        using \<HH>Pmmax.max_normal \<HH>Pmmax.is_normal \<GG>PnnormG comp\<GG>.normal_subgroup_set_mult_closed \<HH>PmSubSetmult' by metis
      from set_multG obtain \<psi> where
            "\<psi> \<in> iso (\<HH>Pm Mod (\<GG> ! (n - 1) \<inter> \<HH> ! (m - 1))) (G\<lparr>carrier := carrier G\<rparr> Mod \<GG> ! (n - 1))"
        using second_isomorphism_grp.normal_intersection_quotient_isom \<GG>PnnormG \<HH>Pmmax.is_normal normal_imp_subgroup
        unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def max_normal_subgroup_def \<HH>Pm_def by metis
      hence \<psi>:"\<psi> \<in> iso (\<HH>Pm Mod (\<HH> ! (m - 1) \<inter> (\<GG> ! (n - 1)))) (G\<lparr>carrier := carrier G\<rparr> Mod \<GG> ! (n - 1))" using Int_commute by metis
      then obtain \<psi>2 where
             \<psi>2:"\<psi>2 \<in> iso (G Mod \<GG> ! (n - 1)) (\<HH>Pm Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)))"
        using group.iso_set_sym grp\<HH>PmMod\<HH>Pmint\<GG>Pn.is_group by auto
      moreover have "simple_group (G\<lparr>carrier := \<GG> ! (n - 1 + 1)\<rparr> Mod \<GG> ! (n - 1))" using comp\<GG>.simplefact n'(3) by simp
      hence "simple_group (G Mod \<GG> ! (n - 1))" using comp\<GG>.last last_conv_nth comp\<GG>.notempty n'(7) by fastforce
      ultimately have simple\<HH>PmModInt:"simple_group (\<HH>Pm Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)))"
        using simple_group.iso_simple grp\<HH>PmMod\<HH>Pmint\<GG>Pn.is_group by auto
      interpret grpGMod\<GG>Pn: group "(G Mod \<GG> ! (n - 1))" by (metis \<GG>PnnormG normal.factorgroup_is_group)

      \<comment> \<open>Instantiate several composition series used to build up the equality of quotient multisets.\<close>
      define \<KK> where "\<KK> = remdups_adj (map ((\<inter>) (\<HH> ! (m - 1))) \<GG>)"
      define \<LL> where "\<LL> = remdups_adj (map ((\<inter>) (\<GG> ! (n - 1))) \<HH>)"
      interpret \<KK>: composition_series \<HH>Pm \<KK> using comp\<GG>.intersect_normal 1(3) \<HH>PmnormG unfolding \<KK>_def \<HH>Pm_def by auto
      interpret \<LL>: composition_series \<GG>Pn \<LL> using comp\<HH>.intersect_normal 1(3) \<GG>PnnormG unfolding \<LL>_def \<GG>Pn_def by auto

      \<comment> \<open>Apply the induction hypothesis on @{text \<GG>butlast} and @{text \<LL>}\<close>
      from n'(2) have "Suc (length (take n \<GG>)) \<le> length \<GG>" by auto
      hence multisets\<GG>butlast\<LL>:"mset (map group.iso_class \<GG>butlast.quotients) = mset (map group.iso_class \<LL>.quotients)"
        using  "1.hyps" grp\<GG>Pn.is_group finGbl \<GG>butlast.is_composition_series \<LL>.is_composition_series by metis
      hence length\<LL>:"n = length \<LL>" using \<GG>butlast.quotients_length \<LL>.quotients_length length_map size_mset ltaken by metis
      hence length\<LL>':"length \<LL> > 1" "length \<LL> - 1 > 0" "length \<LL> - 1 \<le> length \<LL>" using n'(6) length by auto
      have Inteq\<LL>sndlast:"\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) = \<LL> ! (length \<LL> - 1 - 1)"
      proof -
        have "length \<LL> - 1 - 1 + 1 < length \<LL>" using length\<LL>' by auto
        moreover have KGnotempty:"(map ((\<inter>) (\<GG> ! (n - 1))) \<HH>) \<noteq> []" using comp\<HH>.notempty by (metis Nil_is_map_conv)
        ultimately obtain i where i:"i + 1 < length (map ((\<inter>) (\<GG> ! (n - 1))) \<HH>)"
          "\<LL> ! (length \<LL> - 1 - 1) = (map ((\<inter>) (\<GG> ! (n - 1))) \<HH>) ! i" "\<LL> ! (length \<LL> - 1 - 1 + 1) = (map ((\<inter>) (\<GG> ! (n - 1))) \<HH>) ! (i + 1)"
          using remdups_adj_obtain_adjacency unfolding \<LL>_def by force
        hence "\<LL> ! (length \<LL> - 1 - 1) = \<HH> ! i \<inter> \<GG> ! (n - 1)" "\<LL> ! (length \<LL> - 1 - 1 + 1) = \<HH> ! (i + 1) \<inter> \<GG> ! (n - 1)" by auto
        hence "\<LL> ! (length \<LL> - 1) = \<HH> ! (i + 1) \<inter> \<GG> ! (n - 1)" using length\<LL>'(2) by (metis Suc_diff_1 Suc_eq_plus1)
        hence \<GG>Pnsub\<HH>Pm:"\<GG> ! (n - 1) \<subseteq> \<HH> ! (i + 1)" using \<LL>.last \<LL>.notempty last_conv_nth unfolding \<GG>Pn_def by auto
        from i(1) have "i + 1 < m + 1" unfolding m_def by auto
        moreover have "\<not> (i + 1 \<le> m - 1)" using comp\<HH>.entries_mono m'(6) not\<GG>PnSub\<HH>Pm \<GG>Pnsub\<HH>Pm by fastforce
        ultimately have "m - 1 = i" by auto
        with i show ?thesis by auto
      qed
      hence \<LL>sndlast:"\<HH>PmInt\<GG>Pn = (\<GG>Pn\<lparr>carrier := \<LL> ! (length \<LL> - 1 - 1)\<rparr>)" unfolding \<HH>PmInt\<GG>Pn_def \<GG>Pn_def by auto
      then interpret \<LL>butlast: composition_series \<HH>PmInt\<GG>Pn "take (length \<LL> - 1) \<LL>" using length\<LL>' \<LL>.composition_series_prefix_closed by metis
      from \<open>length \<LL> > 1\<close> have quots\<LL>notemtpy:"\<LL>.quotients \<noteq> []" unfolding \<LL>.quotients_def by auto

      \<comment> \<open>Apply the induction hypothesis on @{text \<LL>butlast} and @{text \<KK>butlast}\<close>
      have "length \<KK> > 1"
      proof (rule ccontr)
        assume "\<not> length \<KK> > 1"
        with \<KK>.notempty have "length \<KK> = 1" by (metis One_nat_def Suc_lessI length_greater_0_conv)
        hence "carrier \<HH>Pm = {\<one>\<^bsub>\<HH>Pm\<^esub>}" using \<KK>.composition_series_length_one \<KK>.composition_series_triv_group by auto
        hence "carrier \<HH>Pm = {\<one>\<^bsub>G\<^esub>}" unfolding \<HH>Pm_def by auto
        hence "carrier \<HH>Pm \<subseteq> \<GG> ! (n - 1)" using \<GG>Pnmax.is_subgroup subgroup.one_closed by auto
        with not\<HH>PmSub\<GG>Pn show False unfolding \<HH>Pm_def by auto
      qed
      hence length\<KK>':"length \<KK> - 1 > 0" "length \<KK> - 1 \<le> length \<KK>" by auto
      have Inteq\<KK>sndlast:"\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) = \<KK> ! (length \<KK> - 1 - 1)"
      proof -
        have "length \<KK> - 1 - 1 + 1 < length \<KK>" using length\<KK>' by auto
        moreover have KGnotempty:"(map ((\<inter>) (\<HH> ! (m - 1))) \<GG>) \<noteq> []" using comp\<GG>.notempty by (metis Nil_is_map_conv)
        ultimately obtain i where i:"i + 1 < length (map ((\<inter>) (\<HH> ! (m - 1))) \<GG>)"
          "\<KK> ! (length \<KK> - 1 - 1) = (map ((\<inter>) (\<HH> ! (m - 1))) \<GG>) ! i" "\<KK> ! (length \<KK> - 1 - 1 + 1) = (map ((\<inter>) (\<HH> ! (m - 1))) \<GG>) ! (i + 1)"
          using remdups_adj_obtain_adjacency unfolding \<KK>_def by force
        hence "\<KK> ! (length \<KK> - 1 - 1) = \<GG> ! i \<inter> \<HH> ! (m - 1)" "\<KK> ! (length \<KK> - 1 - 1 + 1) = \<GG> ! (i + 1) \<inter> \<HH> ! (m - 1)" by auto
        hence "\<KK> ! (length \<KK> - 1) = \<GG> ! (i + 1) \<inter> \<HH> ! (m - 1)" using length\<KK>'(1) by (metis Suc_diff_1 Suc_eq_plus1)
        hence \<HH>Pmsub\<GG>Pn:"\<HH> ! (m - 1) \<subseteq> \<GG> ! (i + 1)" using \<KK>.last \<KK>.notempty last_conv_nth unfolding \<HH>Pm_def by auto
        from i(1) have "i + 1 < n + 1" unfolding n_def by auto
        moreover have "\<not> (i + 1 \<le> n - 1)" using comp\<GG>.entries_mono n'(2) not\<HH>PmSub\<GG>Pn \<HH>Pmsub\<GG>Pn by fastforce
        ultimately have "n - 1 = i" by auto
        with i show ?thesis by auto
      qed
      have "composition_series (G\<lparr>carrier := \<KK> ! (length \<KK> - 1 - 1)\<rparr>) (take (length \<KK> - 1) \<KK>)"
        using length\<KK>' \<KK>.composition_series_prefix_closed unfolding \<HH>PmInt\<GG>Pn_def \<HH>Pm_def by fastforce
      then interpret \<KK>butlast: composition_series \<HH>PmInt\<GG>Pn "(take (length \<KK> - 1) \<KK>)" using Inteq\<KK>sndlast unfolding \<HH>PmInt\<GG>Pn_def by auto
      from finGbl have finInt:"finite (carrier \<HH>PmInt\<GG>Pn)" unfolding \<HH>PmInt\<GG>Pn_def \<GG>Pn_def by simp
      moreover have "Suc (length (take (length \<LL> - 1) \<LL>)) \<le> length \<GG>" using length\<LL> unfolding n_def using n'(2) by auto
      ultimately have multisets\<KK>\<LL>butlast:"mset (map group.iso_class \<LL>butlast.quotients) = mset (map group.iso_class \<KK>butlast.quotients)"
         using "1.hyps" \<LL>butlast.is_group \<KK>butlast.is_composition_series \<LL>butlast.is_composition_series by auto
      hence "length (take (length \<KK> - 1) \<KK>) = length (take (length \<LL> - 1) \<LL>)"
        using \<KK>butlast.quotients_length \<LL>butlast.quotients_length length_map size_mset by metis
      hence "length (take (length \<KK> - 1) \<KK>) = n - 1" using length\<LL> n'(1) by auto
      hence length\<KK>:"length \<KK> = n" by (metis Suc_diff_1 \<KK>.notempty butlast_conv_take length_butlast length_greater_0_conv n'(1))

      \<comment> \<open>Apply the induction hypothesis on @{text \<KK>} and @{text \<HH>butlast}\<close>
      from Inteq\<KK>sndlast have \<KK>sndlast:"\<HH>PmInt\<GG>Pn = (\<HH>Pm\<lparr>carrier := \<KK> ! (length \<KK> - 1 - 1)\<rparr>)" unfolding \<HH>PmInt\<GG>Pn_def \<HH>Pm_def \<KK>_def by auto
      from length\<KK> have "Suc (length \<KK>) \<le> length \<GG>" using n'(2) by auto
      hence multisets\<HH>butlast\<KK>:"mset (map group.iso_class \<HH>butlast.quotients) = mset (map group.iso_class \<KK>.quotients)"
        using  "1.hyps" grp\<HH>Pm.is_group finHbl \<HH>butlast.is_composition_series \<KK>.is_composition_series by metis
      hence length\<KK>:"m = length \<KK>" using \<HH>butlast.quotients_length \<KK>.quotients_length length_map size_mset ltakem by metis
      hence  "length \<KK> > 1" "length \<KK> - 1 > 0" "length \<KK> - 1 \<le> length \<KK>" using m'(4) length\<HH>big by auto
      hence quots\<KK>notemtpy:"\<KK>.quotients \<noteq> []" unfolding \<KK>.quotients_def by auto

      interpret \<KK>butlastadd\<GG>Pn: composition_series \<GG>Pn "(take (length \<KK> - 1) \<KK>) @ [\<GG> ! (n - 1)]"
        using grp\<GG>Pn.composition_series_extend \<KK>butlast.is_composition_series simple\<GG>PnModInt Intnorm\<GG>Pn
        unfolding \<GG>Pn_def \<HH>PmInt\<GG>Pn_def by auto
      interpret \<LL>butlastadd\<HH>Pm: composition_series \<HH>Pm "(take (length \<LL> - 1) \<LL>) @ [\<HH> ! (m - 1)]"
        using grp\<HH>Pm.composition_series_extend \<LL>butlast.is_composition_series simple\<HH>PmModInt Intnorm\<HH>Pm
        unfolding \<HH>Pm_def \<HH>PmInt\<GG>Pn_def by auto

      \<comment> \<open>Prove equality of those composition series.\<close>
      have "mset (map group.iso_class comp\<GG>.quotients)
                    = mset (map group.iso_class ((butlast comp\<GG>.quotients) @ [last comp\<GG>.quotients]))" using quots\<GG>notempty by simp
      also have "\<dots> = mset (map group.iso_class (\<GG>butlast.quotients @ [G Mod \<GG> ! (n - 1)]))"
        using comp\<GG>.quotients_butlast comp\<GG>.last_quotient length unfolding n_def \<GG>Pn_def by auto
      also have "\<dots> = mset (map group.iso_class ((butlast \<LL>.quotients) @ [last \<LL>.quotients])) + {# group.iso_class (G Mod \<GG> ! (n - 1)) #}"
        using multisets\<GG>butlast\<LL> quots\<LL>notemtpy by simp
      also have "\<dots> = mset (map group.iso_class (\<LL>butlast.quotients @ [\<GG>Pn Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)])) + {# group.iso_class (G Mod \<GG> ! (n - 1)) #}"
        using \<LL>.quotients_butlast \<LL>.last_quotient \<open>length \<LL> > 1\<close> \<LL>sndlast Inteq\<LL>sndlast unfolding n_def by auto
      also have "\<dots> = mset (map group.iso_class \<KK>butlast.quotients) + {# group.iso_class (\<GG>Pn Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)) #} + {# group.iso_class (G Mod \<GG> ! (n - 1)) #}"
        using multisets\<KK>\<LL>butlast by simp
      also have "\<dots> = mset (map group.iso_class \<KK>butlast.quotients) + {# group.iso_class (G Mod \<HH> ! (m - 1)) #} + {# group.iso_class (\<HH>Pm Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)) #}"
        using \<phi> \<psi>2 iso_classes_iff grp\<GG>PnMod\<HH>Pmint\<GG>Pn.is_group grpGMod\<HH>Pm.is_group grpGMod\<GG>Pn.is_group grp\<HH>PmMod\<HH>Pmint\<GG>Pn.is_group
        by metis
      also have "\<dots> = mset (map group.iso_class \<KK>butlast.quotients) + {# group.iso_class (\<HH>Pm Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)) #} + {# group.iso_class (G Mod \<HH> ! (m - 1)) #}"
        by simp
      also have "\<dots> = mset (map group.iso_class ((butlast \<KK>.quotients) @ [last \<KK>.quotients])) + {# group.iso_class (G Mod \<HH> ! (m - 1)) #}"
        using \<KK>.quotients_butlast \<KK>.last_quotient \<open>length \<KK> > 1\<close> \<KK>sndlast Inteq\<KK>sndlast unfolding m_def by auto
      also have "\<dots> = mset (map group.iso_class \<HH>butlast.quotients) + {# group.iso_class (G Mod \<HH> ! (m - 1)) #}"
        using multisets\<HH>butlast\<KK> quots\<KK>notemtpy by simp
      also have "\<dots> = mset (map group.iso_class ((butlast comp\<HH>.quotients) @ [last comp\<HH>.quotients]))"
        using comp\<HH>.quotients_butlast comp\<HH>.last_quotient length\<HH>big unfolding m_def \<HH>Pm_def by auto
      also have "\<dots> = mset (map group.iso_class comp\<HH>.quotients)" using quots\<HH>notempty by simp
      finally show ?thesis .
    qed
  qed
qed

text \<open>As a corollary, we see that the composition series of a fixed group all have the same length.\<close>

corollary (in jordan_hoelder) jordan_hoelder_size:
  shows "length \<GG> = length \<HH>"
proof -
  have "length \<GG> = length comp\<GG>.quotients + 1" by (metis comp\<GG>.quotients_length)
  also have "\<dots> = length (map group.iso_class comp\<GG>.quotients) + 1" by (metis length_map)
  also have "\<dots> = size (mset (map group.iso_class comp\<GG>.quotients)) + 1" by (metis size_mset)
  also have "\<dots> = size (mset (map group.iso_class comp\<HH>.quotients)) + 1"
    using jordan_hoelder_multisets is_group finite is_composition_series comp\<HH>.is_composition_series by metis
  also have "\<dots> = length (map group.iso_class comp\<HH>.quotients) + 1" by (metis size_mset)
  also have "\<dots> = length comp\<HH>.quotients + 1" by (metis length_map)
  also have "\<dots> = length \<HH>" by (metis comp\<HH>.quotients_length)
  finally show ?thesis.
qed

end


theory Temporal imports Main
begin
  section\<open>Linear Temporal Logic\<close>
  text\<open>
    In this section we introduce an algebraic axiomatization of Linear Temporal Logic (LTL).
    We model LTL formulas semantically as predicates on traces. For example the LTL formula
    $\alpha = \Box\; \diamondsuit\; (x = 1)$ is modeled as a predicate
    $\alpha : (nat \Rightarrow nat) \Rightarrow bool$, where
    $\alpha \;x = True$ if $x\;i=1$ for infinitely many $i:nat$. In this formula $\Box$
    and $\diamondsuit$ denote the always and eventually operators, respectively.
    Formulas with multiple variables are modeled similarly. For example a formula $\alpha$ in two
    variables is modeled as $\alpha : (nat \Rightarrow \tv a) \Rightarrow (nat \Rightarrow \tv b) \Rightarrow bool$,
    and for example $(\Box\; \alpha) \; x\; y$ is defined as $(\forall i . \alpha \; x[i..]\; y[i..])$,
    where $x[i..]\;j = x\;(i+j)$. We would like to construct an algebraic structure (Isabelle class)
    which has the temporal operators as operations, and which has instatiations to
    $(nat \Rightarrow \tv a) \Rightarrow bool$, $(nat \Rightarrow \tv a) \Rightarrow (nat \Rightarrow \tv b) \Rightarrow bool$,
    and so on. Ideally our structure should be such that if we have this structure on a type $\tv a::temporal$,
    then we could extend it to $(nat \Rightarrow \tv b) \Rightarrow \tv a$ in a way similar to the
    way Boolean algebras are extended from a type $\tv a::boolean\_algebra$ to $\tv b\Rightarrow \tv a$.
    Unfortunately, if we use for example $\Box$ as primitive operation on our temporal structure,
    then we cannot extend $\Box$ from $\tv a::temporal$ to $(nat \Rightarrow \tv b) \Rightarrow \tv a$. A
    possible extension of $\Box$ could be
      $$(\Box\; \alpha)\;x = \bigwedge_{i:nat} \Box (\alpha\; x[i..]) \mbox{ and } \Box \; b = b$$
    where $\alpha: (nat \Rightarrow \tv b) \Rightarrow \tv a$ and $b:bool$. However, if we apply this
    definition to $\alpha : (nat \Rightarrow \tv a) \Rightarrow (nat \Rightarrow \tv b) \Rightarrow bool$,
    then we get
      $$(\Box\; \alpha) \; x\; y = (\forall i\;j. \alpha \; x[i..]\; y[j..])$$
    which is not correct.

    To evercome this problem we introduce as a primitive operation $!!:\tv a \Rightarrow nat \Rightarrow \tv a$,
    where $\tv a$ is the type of temporal formulas, and $\alpha !! i$ is the formula $\alpha$ at time point $i$.
    If $\alpha$ is a formula in two variables as before, then
      $$(\alpha !! i)\; x\;y = \alpha\; x[i..]\;y[i..].$$
    and we define for example the the operator always by
      $$\Box \alpha = \bigwedge_{i:nat} \alpha !! i$$
\<close>
  notation
    bot ("\<bottom>") and
    top ("\<top>") and
    inf (infixl "\<sqinter>" 70)
    and sup (infixl "\<squnion>" 65)

  class temporal = complete_boolean_algebra +
    fixes at :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 150)
    assumes [simp]: "a !! i !! j = a !! (i + j)"
    assumes [simp]: "a !! 0 = a"
    assumes [simp]: "\<top> !! i = \<top>"
    assumes [simp]: "-(a !! i) = (-a) !! i"
    assumes [simp]: "(a \<sqinter> b) !! i = (a !! i) \<sqinter> (b !! i)"
    begin
      definition always :: "'a \<Rightarrow> 'a"  ("\<box> (_)" [900] 900) where
        "\<box> p = (INF i . p !! i)"

      definition eventually :: "'a \<Rightarrow> 'a"  ("\<diamond> (_)" [900] 900) where
        "\<diamond> p = (SUP i . p !! i)"

      definition "next" :: "'a \<Rightarrow> 'a"  ("\<circle> (_)" [900] 900) where
        "\<circle> p = p !! (Suc 0)"

      definition until :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "until" 65) where
        "(p until q) = (SUP n . (Inf (at p ` {i . i < n})) \<sqinter> (q !! n))"
    end

text\<open>
Next lemma, in the context of complete boolean algebras, will be used
to prove $-(p\ until\ -p) = \Box\; p$.
\<close>
  context complete_boolean_algebra
    begin
      lemma until_always: "(INF n. (SUP i \<in> {i. i < n} . - p i) \<squnion> ((p :: nat \<Rightarrow> 'a) n)) \<le> p n"
        proof -
          have "(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> (INF i\<in>{i. i \<le> n}. p i)"
            proof (induction n)
              have "(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> (SUP i\<in>{i. i < 0}. - p i) \<squnion> p 0"
                by (rule INF_lower, simp)
              also have "... \<le> (INF i\<in>{i. i \<le> 0}. p i)"
                by simp
              finally show "(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> (INF i\<in>{i. i \<le> 0}. p i)"
                by simp
            next
              fix n::nat assume "(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> (INF i \<in> {i. i \<le> n}. p i)"
              also have "\<And> i . i \<le> n \<Longrightarrow> ... \<le> p i" by (rule INF_lower, simp)
              finally have [simp]: "\<And> i . i \<le> n \<Longrightarrow> (INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> p i"
                by simp
              show "(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> (INF i \<in> {i. i \<le> Suc n}. p i)"
                proof (rule INF_greatest, safe, cases)
                  fix i::nat
                    assume "i \<le> n" from this show "(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> p i" by simp
                next
                  fix i::nat
                    have A: "{i. i \<le> n} = {i . i < Suc n}" by auto
                    have B: "(SUP i\<in>{i. i \<le> n}. - p i) \<le> - (INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n)"
                      by (metis (lifting, mono_tags) \<open>(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> (INF i\<in>{i. i \<le> n}. p i)\<close> compl_mono uminus_INF)
                    assume "i \<le> Suc n" and "\<not> i \<le> n"
                    from this have [simp]: "i = Suc n" by simp
                    have "(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> (INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<sqinter> ((SUP i\<in>{i. i \<le> n}. - p i) \<squnion> p (Suc n))"
                      by (simp add: A, rule INF_lower, simp)
                    also have "... \<le> ((INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<sqinter> ((- (INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n)) \<squnion> p (Suc n)))"
                      by (rule inf_mono, simp_all, rule_tac y = "- (INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n)" in order_trans, simp_all add: B)
                    also have "... \<le> p i"
                      by (simp add: inf_sup_distrib1 inf_compl_bot)
                    finally show "(INF n. (SUP i\<in>{i. i < n}. - p i) \<squnion> p n) \<le> p i" by simp
                qed
            qed
        also have "(INF i\<in>{i. i \<le> n}. p i) \<le> p n" by (rule INF_lower, auto)
        finally show "(INF n. (SUP i \<in> {i. i < n} . - p i) \<squnion> ((p :: nat \<Rightarrow> 'a) n)) \<le> p n" by simp
        qed

     end

text\<open>
  We prove now a number of results of the temporal class.
\<close>
  context temporal
    begin

      lemma always_less [simp]: "\<box> p \<le> p"
        proof -
          have "\<box> p \<le> p !! 0"
            by (unfold always_def, rule INF_lower, simp)
          also have "p !! 0 = p" by simp
          finally show "\<box> p \<le> p" by simp
        qed

      lemma always_and: "\<box> (p \<sqinter> q) = (\<box> p) \<sqinter> (\<box> q)"
        by (simp add: always_def INF_inf_distrib)

      lemma eventually_or: "\<diamond> (p \<squnion> q) = (\<diamond> p) \<squnion> (\<diamond> q)"
        by (simp add: eventually_def SUP_sup_distrib)

      lemma neg_until_always: "-(p until -p) = \<box> p"
        proof (rule antisym)
          show "- (p until - p) \<le> \<box> p"
           by (simp add: until_def always_def uminus_SUP uminus_INF, rule INF_greatest, cut_tac p = "\<lambda> n . p !! n" in until_always, simp)
        next
          have "\<And> n . \<box> p \<le> p !! n"
            by (simp add: always_def INF_lower)
          also have "\<And> n . p !! n \<le> (SUP x\<in>{i. i < n}. (- p) !! x) \<squnion> p !! n"
            by simp
          finally show "\<box> p \<le> -(p until -p)"
            apply (simp add: until_def uminus_SUP uminus_INF)
            by (rule INF_greatest, simp)
        qed

      lemma neg_always_eventually: "\<box> p = - \<diamond> (- p)"
        by (simp add: fun_eq_iff always_def eventually_def until_def uminus_SUP)

      lemma neg_true_until_always: "-(\<top> until -p) = \<box> p"
        by (simp add: fun_eq_iff always_def until_def uminus_SUP uminus_INF)

      lemma true_until_eventually: "(\<top> until p) = \<diamond> p"
        by (cut_tac p = "-p" in neg_always_eventually, cut_tac p = "-p" in neg_true_until_always, simp)
    end

text\<open>
  Boolean algebras with $b!!i = b$ form a temporal class.
\<close>

  instantiation bool :: temporal
    begin
      definition at_bool_def [simp]: "(p::bool) !! i = p"
    instance proof
      qed auto
    end

  type_synonym 'a trace = "nat \<Rightarrow> 'a"

text\<open>
  Asumming that $\tv a::temporal$ is a type of class $temporal$, and $\tv b$ is an arbitrary type,
  we would like to create the instantiation of $\tv b\ trace \Rightarrow \tv a$ as a temporal
  class. However Isabelle allows only instatiations of functions from a class to another
  class. To solve this problem we introduce a new class called trace with an operation
  $\mathit{suffix}::\tv a \Rightarrow nat \Rightarrow \tv a$ where
  $\mathit{suffix}\;a\;i\;j = (a[i..])\; j = a\;(i+j)$ when
  $a$ is a trace with elements of some type $\tv b$ ($\tv a = nat \Rightarrow \tv b$).
\<close>

  class trace =
    fixes suffix :: "'a \<Rightarrow> nat \<Rightarrow> 'a" ("_[_ ..]" [80, 15] 80)
    assumes [simp]: "a[i..][j..] = a[i + j..]"
    assumes [simp]: "a[0..] = a"
    begin
      definition "next_trace" :: "'a \<Rightarrow> 'a"  ("\<odot> (_)" [900] 900) where
        "\<odot> p = p[Suc 0..]"
    end

  instantiation "fun" :: (trace, temporal) temporal
    begin
      definition at_fun_def: "(P:: 'a \<Rightarrow> 'b) !! i = (\<lambda> x . (P (x[i..])) !! i)"
      instance proof qed  (simp_all add: at_fun_def add.commute fun_eq_iff le_fun_def)
    end

text\<open>
  In the last part of our formalization, we need to instantiate the functions
  from $nat$ to some arbitrary type $\tv a$ as a trace class. However, this again is not
  possible using the instatiation mechanism of Isabelle. We solve this problem
  by creating another class called $nat$, and then we instatiate the functions
  from $\tv a::nat$ to $\tv b$ as traces. The class $nat$ is defined such that if we
  have a type $\tv a::nat$, then $\tv a$ is isomorphic to the type $nat$.
\<close>

  class nat = zero + plus + minus +
    fixes RepNat :: "'a \<Rightarrow> nat"
    fixes AbsNat :: "nat \<Rightarrow> 'a"
    assumes [simp]: "RepNat (AbsNat n) = n"
    and [simp]: "AbsNat (RepNat x) = x"
    and zero_Nat_def: "0 = AbsNat 0"
    and plus_Nat_def: "a + b = AbsNat (RepNat a + RepNat b)"
    and minus_Nat_def: "a - b = AbsNat (RepNat a - RepNat b)"
  begin
    lemma AbsNat_plus: "AbsNat (i + j) = AbsNat i + AbsNat j"
      by (simp add: plus_Nat_def)
    lemma AbsNat_zero [simp]: "AbsNat 0 + i = i"
      by (simp add: plus_Nat_def)

    subclass comm_monoid_diff
      apply (unfold_locales)
        apply (simp_all add: plus_Nat_def zero_Nat_def minus_Nat_def add.assoc)
        by (simp add: add.commute)
  end

text\<open>
  The type natural numbers is an instantiation of the class $nat$.
\<close>

  instantiation nat :: nat
    begin
      definition RepNat_nat_def [simp]: "(RepNat:: nat \<Rightarrow> nat) = id"
      definition AbsNat_nat_def [simp]: "(AbsNat:: nat \<Rightarrow> nat) = id"
      instance proof
        qed auto
    end

text\<open>
  Finally, functions from $\tv a::nat$ to some arbitrary type $\tv b$ are instatiated
  as a trace class.
\<close>

  instantiation "fun" :: (nat, type) trace
    begin
      definition at_trace_def [simp]: "((t :: 'a \<Rightarrow> 'b)[i..]) j = (t  (AbsNat i + j))"
    instance proof
      qed (simp_all add: fun_eq_iff AbsNat_plus add.assoc)
    end

text\<open>
  By putting together all class definitions and instatiations introduced so far, we obtain the
  temporal class structure for predicates on traces with arbitrary number of parameters.

  For example in the next lemma $r$ and $r'$ are predicate relations, and the operator
  always is available for them as a consequence of the above construction.
\<close>

  lemma "(\<box> r) OO (\<box> r') \<le> (\<box> (r OO r'))"
    by (simp add: le_fun_def always_def at_fun_def, auto)

  end


theory test
imports Main
begin

definition is_increasing :: "(nat \<Rightarrow> nat) \<Rightarrow> bool" where
"is_increasing f = (\<forall>n m::nat . n> m \<longrightarrow> f n > f m)"

lemma is_increasing_prop:
 "is_increasing f \<Longrightarrow> f n \<ge>n"
  apply(induction n)
   apply simp
  by (meson Suc_leI Suc_le_mono is_increasing_def le_trans less_Suc_eq)
end