(*  Title:      HOL/Algebra/Group_Action.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Group_Action
imports Bij Coset Congruence
begin

section \<open>Group Actions\<close>

locale group_action =
  fixes G (structure) and E and \<phi>
  assumes group_hom: "group_hom G (BijGroup E) \<phi>"

definition
  orbit :: "[_, 'a \<Rightarrow> 'b \<Rightarrow> 'b, 'b] \<Rightarrow> 'b set"
  where "orbit G \<phi> x = {(\<phi> g) x | g. g \<in> carrier G}"

definition
  orbits :: "[_, 'b set, 'a \<Rightarrow> 'b \<Rightarrow> 'b] \<Rightarrow> ('b set) set"
  where "orbits G E \<phi> = {orbit G \<phi> x | x. x \<in> E}"

definition
  stabilizer :: "[_, 'a \<Rightarrow> 'b \<Rightarrow> 'b, 'b] \<Rightarrow> 'a set"
  where "stabilizer G \<phi> x = {g \<in> carrier G. (\<phi> g) x = x}"

definition
  invariants :: "['b set, 'a \<Rightarrow> 'b \<Rightarrow> 'b, 'a] \<Rightarrow> 'b set"
  where "invariants E \<phi> g = {x \<in> E. (\<phi> g) x = x}"

definition
  normalizer :: "[_, 'a set] \<Rightarrow> 'a set"
  where "normalizer G H =
         stabilizer G (\<lambda>g. \<lambda>H \<in> {H. H \<subseteq> carrier G}. g <#\<^bsub>G\<^esub> H #>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> g)) H"

locale faithful_action = group_action +
  assumes faithful: "inj_on \<phi> (carrier G)"

locale transitive_action = group_action +
  assumes unique_orbit: "\<lbrakk> x \<in> E; y \<in> E \<rbrakk> \<Longrightarrow> \<exists>g \<in> carrier G. (\<phi> g) x = y"

subsection \<open>Prelimineries\<close>

text \<open>Some simple lemmas to make group action's properties more explicit\<close>

lemma (in group_action) id_eq_one: "(\<lambda>x \<in> E. x) = \<phi> \<one>"
  by (metis BijGroup_def group_hom group_hom.hom_one select_convs(2))

lemma (in group_action) bij_prop0:
  "\<And> g. g \<in> carrier G \<Longrightarrow> (\<phi> g) \<in> Bij E"
  by (metis BijGroup_def group_hom group_hom.hom_closed partial_object.select_convs(1))

lemma (in group_action) surj_prop:
  "\<And> g. g \<in> carrier G \<Longrightarrow> (\<phi> g) ` E = E"
  using bij_prop0 by (simp add: Bij_def bij_betw_def)

lemma (in group_action) inj_prop:
  "\<And> g. g \<in> carrier G \<Longrightarrow> inj_on (\<phi> g) E"
  using bij_prop0 by (simp add: Bij_def bij_betw_def)

lemma (in group_action) bij_prop1:
  "\<And> g y. \<lbrakk> g \<in> carrier G; y \<in> E \<rbrakk> \<Longrightarrow>  \<exists>!x \<in> E. (\<phi> g) x = y"
proof -
  fix g y assume "g \<in> carrier G" "y \<in> E"
  hence "\<exists>x \<in> E. (\<phi> g) x = y"
    using surj_prop by force
  moreover have "\<And> x1 x2. \<lbrakk> x1 \<in> E; x2 \<in> E \<rbrakk> \<Longrightarrow> (\<phi> g) x1 = (\<phi> g) x2 \<Longrightarrow> x1 = x2"
    using inj_prop by (meson \<open>g \<in> carrier G\<close> inj_on_eq_iff)
  ultimately show "\<exists>!x \<in> E. (\<phi> g) x = y"
    by blast
qed

lemma (in group_action) composition_rule:
  assumes "x \<in> E" "g1 \<in> carrier G" "g2 \<in> carrier G"
  shows "\<phi> (g1 \<otimes> g2) x = (\<phi> g1) (\<phi> g2 x)"
proof -
  have "\<phi> (g1 \<otimes> g2) x = ((\<phi> g1) \<otimes>\<^bsub>BijGroup E\<^esub> (\<phi> g2)) x"
    using assms(2) assms(3) group_hom group_hom.hom_mult by fastforce
  also have " ... = (compose E (\<phi> g1) (\<phi> g2)) x"
    unfolding BijGroup_def by (simp add: assms bij_prop0)
  finally show "\<phi> (g1 \<otimes> g2) x = (\<phi> g1) (\<phi> g2 x)"
    by (simp add: assms(1) compose_eq)
qed

lemma (in group_action) element_image:
  assumes "g \<in> carrier G" and "x \<in> E" and "(\<phi> g) x = y"
  shows "y \<in> E"
  using surj_prop assms by blast

subsection \<open>Orbits\<close>

text\<open>We prove here that orbits form an equivalence relation\<close>

lemma (in group_action) orbit_sym_aux:
  assumes "g \<in> carrier G"
    and "x \<in> E"
    and "(\<phi> g) x = y"
  shows "(\<phi> (inv g)) y = x"
proof -
  interpret group G
    using group_hom group_hom.axioms(1) by auto
  have "y \<in> E"
    using element_image assms by simp
  have "inv g \<in> carrier G"
    by (simp add: assms(1))

  have "(\<phi> (inv g)) y = (\<phi> (inv g)) ((\<phi> g) x)"
    using assms(3) by simp
  also have " ... = compose E (\<phi> (inv g)) (\<phi> g) x"
    by (simp add: assms(2) compose_eq)
  also have " ... = ((\<phi> (inv g)) \<otimes>\<^bsub>BijGroup E\<^esub> (\<phi> g)) x"
    by (simp add: BijGroup_def assms(1) bij_prop0)
  also have " ... = (\<phi> ((inv g) \<otimes> g)) x"
    by (metis \<open>inv g \<in> carrier G\<close> assms(1) group_hom group_hom.hom_mult)
  finally show "(\<phi> (inv g)) y = x"
    by (metis assms(1) assms(2) id_eq_one l_inv restrict_apply)
qed

lemma (in group_action) orbit_refl:
  "x \<in> E \<Longrightarrow> x \<in> orbit G \<phi> x"
proof -
  assume "x \<in> E" hence "(\<phi> \<one>) x = x"
    using id_eq_one by (metis restrict_apply')
  thus "x \<in> orbit G \<phi> x" unfolding orbit_def
    using group.is_monoid group_hom group_hom.axioms(1) by force
qed

lemma (in group_action) orbit_sym:
  assumes "x \<in> E" and "y \<in> E" and "y \<in> orbit G \<phi> x"
  shows "x \<in> orbit G \<phi> y"
proof -
  have "\<exists> g \<in> carrier G. (\<phi> g) x = y"
    using assms by (auto simp: orbit_def)
  then obtain g where g: "g \<in> carrier G \<and> (\<phi> g) x = y" by blast
  hence "(\<phi> (inv g)) y = x"
    using orbit_sym_aux by (simp add: assms(1))
  thus ?thesis
    using g group_hom group_hom.axioms(1) orbit_def by fastforce
qed

lemma (in group_action) orbit_trans:
  assumes "x \<in> E" "y \<in> E" "z \<in> E"
    and "y \<in> orbit G \<phi> x" "z \<in> orbit G \<phi> y"
  shows "z \<in> orbit G \<phi> x"
proof -
  interpret group G
    using group_hom group_hom.axioms(1) by auto
  obtain g1 where g1: "g1 \<in> carrier G \<and> (\<phi> g1) x = y"
    using assms by (auto simp: orbit_def)
  obtain g2 where g2: "g2 \<in> carrier G \<and> (\<phi> g2) y = z"
    using assms by (auto simp: orbit_def)
  have "(\<phi> (g2 \<otimes> g1)) x = ((\<phi> g2) \<otimes>\<^bsub>BijGroup E\<^esub> (\<phi> g1)) x"
    using g1 g2 group_hom group_hom.hom_mult by fastforce
  also have " ... = (\<phi> g2) ((\<phi> g1) x)"
    using composition_rule assms(1) calculation g1 g2 by auto
  finally have "(\<phi> (g2 \<otimes> g1)) x = z"
    by (simp add: g1 g2)
  thus ?thesis
    using g1 g2 orbit_def by force
qed

lemma (in group_action) orbits_as_classes:
  "classes\<^bsub>\<lparr> carrier = E, eq = \<lambda>x. \<lambda>y. y \<in> orbit G \<phi> x \<rparr>\<^esub> = orbits G E \<phi>"
  unfolding eq_classes_def eq_class_of_def orbits_def orbit_def
  using element_image by auto

theorem (in group_action) orbit_partition:
  "partition E (orbits G E \<phi>)"
proof -
  have "equivalence \<lparr> carrier = E, eq = \<lambda>x. \<lambda>y. y \<in> orbit G \<phi> x \<rparr>"
  unfolding equivalence_def apply simp
  using orbit_refl orbit_sym orbit_trans by blast
  thus ?thesis using equivalence.partition_from_equivalence orbits_as_classes by fastforce
qed

corollary (in group_action) orbits_coverture:
  "\<Union> (orbits G E \<phi>) = E"
  using partition.partition_coverture[OF orbit_partition] by simp

corollary (in group_action) disjoint_union:
  assumes "orb1 \<in> (orbits G E \<phi>)" "orb2 \<in> (orbits G E \<phi>)"
  shows "(orb1 = orb2) \<or> (orb1 \<inter> orb2) = {}"
  using partition.disjoint_union[OF orbit_partition] assms by auto

corollary (in group_action) disjoint_sum:
  assumes "finite E"
  shows "(\<Sum>orb\<in>(orbits G E \<phi>). \<Sum>x\<in>orb. f x) = (\<Sum>x\<in>E. f x)"
  using partition.disjoint_sum[OF orbit_partition] assms by auto

subsubsection \<open>Transitive Actions\<close>

text \<open>Transitive actions have only one orbit\<close>

lemma (in transitive_action) all_equivalent:
  "\<lbrakk> x \<in> E; y \<in> E \<rbrakk> \<Longrightarrow> x .=\<^bsub>\<lparr>carrier = E, eq = \<lambda>x y. y \<in> orbit G \<phi> x\<rparr>\<^esub> y"
proof -
  assume "x \<in> E" "y \<in> E"
  hence "\<exists> g \<in> carrier G. (\<phi> g) x = y"
    using unique_orbit  by blast
  hence "y \<in> orbit G \<phi> x"
    using orbit_def by fastforce
  thus "x .=\<^bsub>\<lparr>carrier = E, eq = \<lambda>x y. y \<in> orbit G \<phi> x\<rparr>\<^esub> y" by simp
qed

proposition (in transitive_action) one_orbit:
  assumes "E \<noteq> {}"
  shows "card (orbits G E \<phi>) = 1"
proof -
  have "orbits G E \<phi> \<noteq> {}"
    using assms orbits_coverture by auto
  moreover have "\<And> orb1 orb2. \<lbrakk> orb1 \<in> (orbits G E \<phi>); orb2 \<in> (orbits G E \<phi>) \<rbrakk> \<Longrightarrow> orb1 = orb2"
  proof -
    fix orb1 orb2 assume orb1: "orb1 \<in> (orbits G E \<phi>)"
                     and orb2: "orb2 \<in> (orbits G E \<phi>)"
    then obtain x y where x: "orb1 = orbit G \<phi> x" and x_E: "x \<in> E"
                      and y: "orb2 = orbit G \<phi> y" and y_E: "y \<in> E"
      unfolding orbits_def by blast
    hence "x \<in> orbit G \<phi> y" using all_equivalent by auto
    hence "orb1 \<inter> orb2 \<noteq> {}" using x y x_E orbit_refl by auto
    thus "orb1 = orb2" using disjoint_union[of orb1 orb2] orb1 orb2 by auto
  qed
  ultimately show "card (orbits G E \<phi>) = 1"
    by (meson is_singletonI' is_singleton_altdef)
qed

subsection \<open>Stabilizers\<close>

text \<open>We show that stabilizers are subgroups from the acting group\<close>

lemma (in group_action) stabilizer_subset:
  "stabilizer G \<phi> x \<subseteq> carrier G"
  by (metis (no_types, lifting) mem_Collect_eq stabilizer_def subsetI)

lemma (in group_action) stabilizer_m_closed:
  assumes "x \<in> E" "g1 \<in> (stabilizer G \<phi> x)" "g2 \<in> (stabilizer G \<phi> x)"
  shows "(g1 \<otimes> g2) \<in> (stabilizer G \<phi> x)"
proof -
  interpret group G
    using group_hom group_hom.axioms(1) by auto

  have "\<phi> g1 x = x"
    using assms stabilizer_def by fastforce
  moreover have "\<phi> g2 x = x"
    using assms stabilizer_def by fastforce
  moreover have g1: "g1 \<in> carrier G"
    by (meson assms contra_subsetD stabilizer_subset)
  moreover have g2: "g2 \<in> carrier G"
    by (meson assms contra_subsetD stabilizer_subset)
  ultimately have "\<phi> (g1 \<otimes> g2) x = x"
    using composition_rule assms by simp

  thus ?thesis
    by (simp add: g1 g2 stabilizer_def)
qed

lemma (in group_action) stabilizer_one_closed:
  assumes "x \<in> E"
  shows "\<one> \<in> (stabilizer G \<phi> x)"
proof -
  have "\<phi> \<one> x = x"
    by (metis assms id_eq_one restrict_apply')
  thus ?thesis
    using group_def group_hom group_hom.axioms(1) stabilizer_def by fastforce
qed

lemma (in group_action) stabilizer_m_inv_closed:
  assumes "x \<in> E" "g \<in> (stabilizer G \<phi> x)"
  shows "(inv g) \<in> (stabilizer G \<phi> x)"
proof -
  interpret group G
    using group_hom group_hom.axioms(1) by auto

  have "\<phi> g x = x"
    using assms(2) stabilizer_def by fastforce
  moreover have g: "g \<in> carrier G"
    using assms(2) stabilizer_subset by blast
  moreover have inv_g: "inv g \<in> carrier G"
    by (simp add: g)
  ultimately have "\<phi> (inv g) x = x"
    using assms(1) orbit_sym_aux by blast

  thus ?thesis by (simp add: inv_g stabilizer_def)
qed

theorem (in group_action) stabilizer_subgroup:
  assumes "x \<in> E"
  shows "subgroup (stabilizer G \<phi> x) G"
  unfolding subgroup_def
  using stabilizer_subset stabilizer_m_closed stabilizer_one_closed
        stabilizer_m_inv_closed assms by simp

subsection \<open>The Orbit-Stabilizer Theorem\<close>

text \<open>In this subsection, we prove the Orbit-Stabilizer theorem.
      Our approach is to show the existence of a bijection between
      "rcosets (stabilizer G phi x)" and "orbit G phi x". Then we use
      Lagrange's theorem to find the cardinal of the first set.\<close>

subsubsection \<open>Rcosets - Supporting Lemmas\<close>

corollary (in group_action) stab_rcosets_not_empty:
  assumes "x \<in> E" "R \<in> rcosets (stabilizer G \<phi> x)"
  shows "R \<noteq> {}"
  using subgroup.rcosets_non_empty[OF stabilizer_subgroup[OF assms(1)] assms(2)] by simp

corollary (in group_action) diff_stabilizes:
  assumes "x \<in> E" "R \<in> rcosets (stabilizer G \<phi> x)"
  shows "\<And>g1 g2. \<lbrakk> g1 \<in> R; g2 \<in> R \<rbrakk> \<Longrightarrow> g1 \<otimes> (inv g2) \<in> stabilizer G \<phi> x"
  using group.diff_neutralizes[of G "stabilizer G \<phi> x" R] stabilizer_subgroup[OF assms(1)]
        assms(2) group_hom group_hom.axioms(1) by blast

subsubsection \<open>Bijection Between Rcosets and an Orbit - Definition and Supporting Lemmas\<close>

(* This definition could be easier if lcosets were available, and it's indeed a considerable
   modification at Coset theory, since we could derive it easily from the definition of rcosets
   following the same idea we use here: f: rcosets \<rightarrow> lcosets, s.t. f R = (\<lambda>g. inv g) ` R
   is a bijection. *)

definition
  orb_stab_fun :: "[_, ('a \<Rightarrow> 'b \<Rightarrow> 'b), 'a set, 'b] \<Rightarrow> 'b"
  where "orb_stab_fun G \<phi> R x = (\<phi> (inv\<^bsub>G\<^esub> (SOME h. h \<in> R))) x"

lemma (in group_action) orbit_stab_fun_is_well_defined0:
  assumes "x \<in> E" "R \<in> rcosets (stabilizer G \<phi> x)"
  shows "\<And>g1 g2. \<lbrakk> g1 \<in> R; g2 \<in> R \<rbrakk> \<Longrightarrow> (\<phi> (inv g1)) x = (\<phi> (inv g2)) x"
proof -
  fix g1 g2 assume g1: "g1 \<in> R" and g2: "g2 \<in> R"
  have R_carr: "R \<subseteq> carrier G"
    using subgroup.rcosets_carrier[OF stabilizer_subgroup[OF assms(1)]]
          assms(2) group_hom group_hom.axioms(1) by auto
  from R_carr have g1_carr: "g1 \<in> carrier G" using g1 by blast
  from R_carr have g2_carr: "g2 \<in> carrier G" using g2 by blast

  have "g1 \<otimes> (inv g2) \<in> stabilizer G \<phi> x"
    using diff_stabilizes[of x R g1 g2] assms g1 g2 by blast
  hence "\<phi> (g1 \<otimes> (inv g2)) x = x"
    by (simp add: stabilizer_def)
  hence "(\<phi> (inv g1)) x = (\<phi> (inv g1)) (\<phi> (g1 \<otimes> (inv g2)) x)" by simp
  also have " ... = \<phi> ((inv g1) \<otimes> (g1 \<otimes> (inv g2))) x"
    using group_def assms(1) composition_rule g1_carr g2_carr
          group_hom group_hom.axioms(1) monoid.m_closed by fastforce
  also have " ... = \<phi> (((inv g1) \<otimes> g1) \<otimes> (inv g2)) x"
    using group_def g1_carr g2_carr group_hom group_hom.axioms(1) monoid.m_assoc by fastforce
  finally show "(\<phi> (inv g1)) x = (\<phi> (inv g2)) x"
    using group_def g1_carr g2_carr group.l_inv group_hom group_hom.axioms(1) by fastforce
qed

lemma (in group_action) orbit_stab_fun_is_well_defined1:
  assumes "x \<in> E" "R \<in> rcosets (stabilizer G \<phi> x)"
  shows "\<And>g. g \<in> R \<Longrightarrow> (\<phi> (inv (SOME h. h \<in> R))) x = (\<phi> (inv g)) x"
  by (meson assms orbit_stab_fun_is_well_defined0 someI_ex)

lemma (in group_action) orbit_stab_fun_is_inj:
  assumes "x \<in> E"
    and "R1 \<in> rcosets (stabilizer G \<phi> x)"
    and "R2 \<in> rcosets (stabilizer G \<phi> x)"
    and "\<phi> (inv (SOME h. h \<in> R1)) x = \<phi> (inv (SOME h. h \<in> R2)) x"
  shows "R1 = R2"
proof -
  have "(\<exists>g1. g1 \<in> R1) \<and> (\<exists>g2. g2 \<in> R2)"
    using assms(1-3) stab_rcosets_not_empty by auto
  then obtain g1 g2 where g1: "g1 \<in> R1" and g2: "g2 \<in> R2" by blast
  hence g12_carr: "g1 \<in> carrier G \<and> g2 \<in> carrier G"
    using subgroup.rcosets_carrier assms(1-3) group_hom
          group_hom.axioms(1) stabilizer_subgroup by blast

  then obtain r1 r2 where r1: "r1 \<in> carrier G" "R1 = (stabilizer G \<phi> x) #> r1"
                      and r2: "r2 \<in> carrier G" "R2 = (stabilizer G \<phi> x) #> r2"
    using assms(1-3) unfolding RCOSETS_def by blast
  then obtain s1 s2 where s1: "s1 \<in> (stabilizer G \<phi> x)" "g1 = s1 \<otimes> r1"
                      and s2: "s2 \<in> (stabilizer G \<phi> x)" "g2 = s2 \<otimes> r2"
    using g1 g2 unfolding r_coset_def by blast

  have "\<phi> (inv g1) x = \<phi> (inv (SOME h. h \<in> R1)) x"
    using orbit_stab_fun_is_well_defined1[OF assms(1) assms(2) g1] by simp
  also have " ... = \<phi> (inv (SOME h. h \<in> R2)) x"
    using assms(4) by simp
  finally have "\<phi> (inv g1) x = \<phi> (inv g2) x"
    using orbit_stab_fun_is_well_defined1[OF assms(1) assms(3) g2] by simp

  hence "\<phi> g2 (\<phi> (inv g1) x) = \<phi> g2 (\<phi> (inv g2) x)" by simp
  also have " ... = \<phi> (g2 \<otimes> (inv g2)) x"
    using assms(1) composition_rule g12_carr group_hom group_hom.axioms(1) by fastforce
  finally have "\<phi> g2 (\<phi> (inv g1) x) = x"
    using g12_carr assms(1) group.r_inv group_hom group_hom.axioms(1)
          id_eq_one restrict_apply by metis
  hence "\<phi> (g2 \<otimes> (inv g1)) x = x"
    using assms(1) composition_rule g12_carr group_hom group_hom.axioms(1) by fastforce
  hence "g2 \<otimes> (inv g1) \<in> (stabilizer G \<phi> x)"
    using g12_carr group.subgroup_self group_hom group_hom.axioms(1)
          mem_Collect_eq stabilizer_def subgroup_def by (metis (mono_tags, lifting))
  then obtain s where s: "s \<in> (stabilizer G \<phi> x)" "s = g2 \<otimes> (inv g1)" by blast

  let ?h = "s \<otimes> g1"
  have "?h = s \<otimes> (s1 \<otimes> r1)" by (simp add: s1)
  hence "?h = (s \<otimes> s1) \<otimes> r1"
    using stabilizer_subgroup[OF assms(1)] group_def group_hom
          group_hom.axioms(1) monoid.m_assoc r1 s s1 subgroup.mem_carrier by fastforce
  hence inR1: "?h \<in> (stabilizer G \<phi> x) #> r1" unfolding r_coset_def
    using stabilizer_subgroup[OF assms(1)] assms(1) s s1 stabilizer_m_closed by auto

  have "?h = g2" using s stabilizer_subgroup[OF assms(1)] g12_carr group.inv_solve_right
                       group_hom group_hom.axioms(1) subgroup.mem_carrier by metis
  hence inR2: "?h \<in> (stabilizer G \<phi> x) #> r2"
    using g2 r2 by blast

  have "R1 \<inter> R2 \<noteq> {}" using inR1 inR2 r1 r2 by blast
  thus ?thesis
    using stabilizer_subgroup group.rcos_disjoint[of G "stabilizer G \<phi> x"] assms group_hom group_hom.axioms(1)
    unfolding disjnt_def pairwise_def  by blast
qed

lemma (in group_action) orbit_stab_fun_is_surj:
  assumes "x \<in> E" "y \<in> orbit G \<phi> x"
  shows "\<exists>R \<in> rcosets (stabilizer G \<phi> x). \<phi> (inv (SOME h. h \<in> R)) x = y"
proof -
  have "\<exists>g \<in> carrier G. (\<phi> g) x = y"
    using assms(2) unfolding orbit_def by blast
  then obtain g where g: "g \<in> carrier G \<and> (\<phi> g) x = y" by blast

  let ?R = "(stabilizer G \<phi> x) #> (inv g)"
  have R: "?R \<in> rcosets (stabilizer G \<phi> x)"
    unfolding RCOSETS_def using g group_hom group_hom.axioms(1) by fastforce
  moreover have "\<one> \<otimes> (inv g) \<in> ?R"
    unfolding r_coset_def using assms(1) stabilizer_one_closed by auto
  ultimately have "\<phi> (inv (SOME h. h \<in> ?R)) x = \<phi> (inv (\<one> \<otimes> (inv g))) x"
    using orbit_stab_fun_is_well_defined1[OF assms(1)] by simp
  also have " ... = (\<phi> g) x"
    using group_def g group_hom group_hom.axioms(1) monoid.l_one by fastforce
  finally have "\<phi> (inv (SOME h. h \<in> ?R)) x = y"
    using g by simp
  thus ?thesis using R by blast
qed

proposition (in group_action) orbit_stab_fun_is_bij:
  assumes "x \<in> E"
  shows "bij_betw (\<lambda>R. (\<phi> (inv (SOME h. h \<in> R))) x) (rcosets (stabilizer G \<phi> x)) (orbit G \<phi> x)"
  unfolding bij_betw_def
proof
  show "inj_on (\<lambda>R. \<phi> (inv (SOME h. h \<in> R)) x) (rcosets stabilizer G \<phi> x)"
    using orbit_stab_fun_is_inj[OF assms(1)] by (simp add: inj_on_def)
next
  have "\<And>R. R \<in> (rcosets stabilizer G \<phi> x) \<Longrightarrow> \<phi> (inv (SOME h. h \<in> R)) x \<in> orbit G \<phi> x "
  proof -
    fix R assume R: "R \<in> (rcosets stabilizer G \<phi> x)"
    then obtain g where g: "g \<in> R"
      using assms stab_rcosets_not_empty by auto
    hence "\<phi> (inv (SOME h. h \<in> R)) x = \<phi> (inv g) x"
      using R  assms orbit_stab_fun_is_well_defined1 by blast
    thus "\<phi> (inv (SOME h. h \<in> R)) x \<in> orbit G \<phi> x" unfolding orbit_def
      using subgroup.rcosets_carrier group_hom group_hom.axioms(1)
            g R assms stabilizer_subgroup by fastforce
  qed
  moreover have "orbit G \<phi> x \<subseteq> (\<lambda>R. \<phi> (inv (SOME h. h \<in> R)) x) ` (rcosets stabilizer G \<phi> x)"
    using assms orbit_stab_fun_is_surj by fastforce
  ultimately show "(\<lambda>R. \<phi> (inv (SOME h. h \<in> R)) x) ` (rcosets stabilizer G \<phi> x) = orbit G \<phi> x "
    using assms set_eq_subset by blast
qed

subsubsection \<open>The Theorem\<close>

theorem (in group_action) orbit_stabilizer_theorem:
  assumes "x \<in> E"
  shows "card (orbit G \<phi> x) * card (stabilizer G \<phi> x) = order G"
proof -
  have "card (rcosets stabilizer G \<phi> x) = card (orbit G \<phi> x)"
    using orbit_stab_fun_is_bij[OF assms(1)] bij_betw_same_card by blast
  moreover have "card (rcosets stabilizer G \<phi> x) * card (stabilizer G \<phi> x) = order G"
    using stabilizer_subgroup assms group.lagrange group_hom group_hom.axioms(1) by blast
  ultimately show ?thesis by auto
qed

subsection \<open>The Burnside's Lemma\<close>

subsubsection \<open>Sums and Cardinals\<close>

lemma card_as_sums:
  assumes "A = {x \<in> B. P x}" "finite B"
  shows "card A = (\<Sum>x\<in>B. (if P x then 1 else 0))"
proof -
  have "A \<subseteq> B" using assms(1) by blast
  have "card A = (\<Sum>x\<in>A. 1)" by simp
  also have " ... = (\<Sum>x\<in>A. (if P x then 1 else 0))"
    by (simp add: assms(1))
  also have " ... = (\<Sum>x\<in>A. (if P x then 1 else 0)) + (\<Sum>x\<in>(B - A). (if P x then 1 else 0))"
    using assms(1) by auto
  finally show "card A = (\<Sum>x\<in>B. (if P x then 1 else 0))"
    using \<open>A \<subseteq> B\<close> add.commute assms(2) sum.subset_diff by metis
qed

lemma sum_invertion:
  "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> (\<Sum>x\<in>A. \<Sum>y\<in>B. f x y) = (\<Sum>y\<in>B. \<Sum>x\<in>A. f x y)"
proof (induct set: finite)
  case empty thus ?case by simp
next
  case (insert x A')
  have "(\<Sum>x\<in>insert x A'. \<Sum>y\<in>B. f x y) = (\<Sum>y\<in>B. f x y) + (\<Sum>x\<in>A'. \<Sum>y\<in>B. f x y)"
    by (simp add: insert.hyps)
  also have " ... = (\<Sum>y\<in>B. f x y) + (\<Sum>y\<in>B. \<Sum>x\<in>A'. f x y)"
    using insert.hyps by (simp add: insert.prems)
  also have " ... = (\<Sum>y\<in>B. (f x y) + (\<Sum>x\<in>A'. f x y))"
    by (simp add: sum.distrib)
  finally have "(\<Sum>x\<in>insert x A'. \<Sum>y\<in>B. f x y) = (\<Sum>y\<in>B. \<Sum>x\<in>insert x A'. f x y)"
    using sum.swap by blast
  thus ?case by simp
qed

lemma (in group_action) card_stablizer_sum:
  assumes "finite (carrier G)" "orb \<in> (orbits G E \<phi>)"
  shows "(\<Sum>x \<in> orb. card (stabilizer G \<phi> x)) = order G"
proof -
  obtain x where x:"x \<in> E" and orb:"orb = orbit G \<phi> x"
    using assms(2) unfolding orbits_def by blast
  have "\<And>y. y \<in> orb \<Longrightarrow> card (stabilizer G \<phi> x) = card (stabilizer G \<phi> y)"
  proof -
    fix y assume "y \<in> orb"
    hence y: "y \<in> E \<and> y \<in> orbit G \<phi> x"
      using x orb assms(2) orbits_coverture by auto
    hence same_orbit: "(orbit G \<phi> x) = (orbit G \<phi> y)"
      using disjoint_union[of "orbit G \<phi> x" "orbit G \<phi> y"] orbit_refl x
      unfolding orbits_def by auto
    have "card (orbit G \<phi> x) * card (stabilizer G \<phi> x) =
          card (orbit G \<phi> y) * card (stabilizer G \<phi> y)"
      using y assms(1) x orbit_stabilizer_theorem by simp
    hence "card (orbit G \<phi> x) * card (stabilizer G \<phi> x) =
           card (orbit G \<phi> x) * card (stabilizer G \<phi> y)" using same_orbit by simp
    moreover have "orbit G \<phi> x \<noteq> {} \<and> finite (orbit G \<phi> x)"
      using y orbit_def[of G \<phi> x] assms(1) by auto
    hence "card (orbit G \<phi> x) > 0"
      by (simp add: card_gt_0_iff)
    ultimately show "card (stabilizer G \<phi> x) = card (stabilizer G \<phi> y)" by auto
  qed
  hence "(\<Sum>x \<in> orb. card (stabilizer G \<phi> x)) = (\<Sum>y \<in> orb. card (stabilizer G \<phi> x))" by auto
  also have " ... = card (stabilizer G \<phi> x) * (\<Sum>y \<in> orb. 1)" by simp
  also have " ... = card (stabilizer G \<phi> x) * card (orbit G \<phi> x)"
    using orb by auto
  finally show "(\<Sum>x \<in> orb. card (stabilizer G \<phi> x)) = order G"
    by (metis mult.commute orbit_stabilizer_theorem x)
qed

subsubsection \<open>The Lemma\<close>

theorem (in group_action) burnside:
  assumes "finite (carrier G)" "finite E"
  shows "card (orbits G E \<phi>) * order G = (\<Sum>g \<in> carrier G. card(invariants E \<phi> g))"
proof -
  have "(\<Sum>g \<in> carrier G. card(invariants E \<phi> g)) =
        (\<Sum>g \<in> carrier G. \<Sum>x \<in> E. (if (\<phi> g) x = x then 1 else 0))"
    by (simp add: assms(2) card_as_sums invariants_def)
  also have " ... = (\<Sum>x \<in> E. \<Sum>g \<in> carrier G. (if (\<phi> g) x = x then 1 else 0))"
    using sum_invertion[where ?f = "\<lambda> g x. (if (\<phi> g) x = x then 1 else 0)"] assms by auto
  also have " ... = (\<Sum>x \<in> E. card (stabilizer G \<phi> x))"
    by (simp add: assms(1) card_as_sums stabilizer_def)
  also have " ... = (\<Sum>orbit \<in> (orbits G E \<phi>). \<Sum>x \<in> orbit. card (stabilizer G \<phi> x))"
    using disjoint_sum orbits_coverture assms(2) by metis
  also have " ... = (\<Sum>orbit \<in> (orbits G E \<phi>). order G)"
    by (simp add: assms(1) card_stablizer_sum)
  finally have "(\<Sum>g \<in> carrier G. card(invariants E \<phi> g)) = card (orbits G E \<phi>) * order G" by simp
  thus ?thesis by simp
qed

subsection \<open>Action by Conjugation\<close>

subsubsection \<open>Action Over Itself\<close>

text \<open>A Group Acts by Conjugation Over Itself\<close>

lemma (in group) conjugation_is_inj:
  assumes "g \<in> carrier G" "h1 \<in> carrier G" "h2 \<in> carrier G"
    and "g \<otimes> h1 \<otimes> (inv g) = g \<otimes> h2 \<otimes> (inv g)"
    shows "h1 = h2"
  using assms by auto

lemma (in group) conjugation_is_surj:
  assumes "g \<in> carrier G" "h \<in> carrier G"
  shows "g \<otimes> ((inv g) \<otimes> h \<otimes> g) \<otimes> (inv g) = h"
  using assms m_assoc inv_closed inv_inv m_closed monoid_axioms r_inv r_one
  by metis

lemma (in group) conjugation_is_bij:
  assumes "g \<in> carrier G"
  shows "bij_betw (\<lambda>h \<in> carrier G. g \<otimes> h \<otimes> (inv g)) (carrier G) (carrier G)"
         (is "bij_betw ?\<phi> (carrier G) (carrier G)")
  unfolding bij_betw_def
proof
  show "inj_on ?\<phi> (carrier G)"
    using conjugation_is_inj by (simp add: assms inj_on_def)
next
  have S: "\<And> h. h \<in> carrier G \<Longrightarrow> (inv g) \<otimes> h \<otimes> g \<in> carrier G"
    using assms by blast
  have "\<And> h. h \<in> carrier G \<Longrightarrow> ?\<phi> ((inv g) \<otimes> h \<otimes> g) = h"
    using assms by (simp add: conjugation_is_surj)
  hence "carrier G \<subseteq> ?\<phi> ` carrier G"
    using S image_iff by fastforce
  moreover have "\<And> h. h \<in> carrier G \<Longrightarrow> ?\<phi> h \<in> carrier G"
    using assms by simp
  hence "?\<phi> ` carrier G \<subseteq> carrier G" by blast
  ultimately show "?\<phi> ` carrier G = carrier G" by blast
qed

lemma(in group) conjugation_is_hom:
  "(\<lambda>g. \<lambda>h \<in> carrier G. g \<otimes> h \<otimes> inv g) \<in> hom G (BijGroup (carrier G))"
  unfolding hom_def
proof -
  let ?\<psi> = "\<lambda>g. \<lambda>h. g \<otimes> h \<otimes> inv g"
  let ?\<phi> = "\<lambda>g. restrict (?\<psi> g) (carrier G)"

  (* First, we prove that ?\<phi>: G \<rightarrow> Bij(G) is well defined *)
  have Step0: "\<And> g. g \<in> carrier G \<Longrightarrow> (?\<phi> g) \<in> Bij (carrier G)"
    using Bij_def conjugation_is_bij by fastforce
  hence Step1: "?\<phi>: carrier G \<rightarrow> carrier (BijGroup (carrier G))"
    unfolding BijGroup_def by simp

  (* Second, we prove that ?\<phi> is a homomorphism *)
  have "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
                  (\<And> h. h \<in> carrier G \<Longrightarrow> ?\<psi> (g1 \<otimes> g2) h = (?\<phi> g1) ((?\<phi> g2) h))"
  proof -
    fix g1 g2 h assume g1: "g1 \<in> carrier G" and g2: "g2 \<in> carrier G" and h: "h \<in> carrier G"
    have "inv (g1 \<otimes> g2) = (inv g2) \<otimes> (inv g1)"
      using g1 g2 by (simp add: inv_mult_group)
    thus "?\<psi> (g1 \<otimes> g2) h  = (?\<phi> g1) ((?\<phi> g2) h)"
      by (simp add: g1 g2 h m_assoc)
  qed
  hence "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
         (\<lambda> h \<in> carrier G. ?\<psi> (g1 \<otimes> g2) h) = (\<lambda> h \<in> carrier G. (?\<phi> g1) ((?\<phi> g2) h))" by auto
  hence Step2: "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
                ?\<phi> (g1 \<otimes> g2) = (?\<phi> g1) \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> (?\<phi> g2)"
    unfolding BijGroup_def by (simp add: Step0 compose_def)

  (* Finally, we combine both results to prove the lemma *)
  thus "?\<phi> \<in> {h: carrier G \<rightarrow> carrier (BijGroup (carrier G)).
              (\<forall>x \<in> carrier G. \<forall>y \<in> carrier G. h (x \<otimes> y) = h x \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> h y)}"
    using Step1 Step2 by auto
qed

theorem (in group) action_by_conjugation:
  "group_action G (carrier G) (\<lambda>g. (\<lambda>h \<in> carrier G. g \<otimes> h \<otimes> (inv g)))"
  unfolding group_action_def group_hom_def using conjugation_is_hom
  by (simp add: group_BijGroup group_hom_axioms.intro is_group)

subsubsection \<open>Action Over The Set of Subgroups\<close>

text \<open>A Group Acts by Conjugation Over The Set of Subgroups\<close>

lemma (in group) subgroup_conjugation_is_inj_aux:
  assumes "g \<in> carrier G" "H1 \<subseteq> carrier G" "H2 \<subseteq> carrier G"
    and "g <# H1 #> (inv g) = g <# H2 #> (inv g)"
    shows "H1 \<subseteq> H2"
proof
  fix h1 assume h1: "h1 \<in> H1"
  hence "g \<otimes> h1 \<otimes> (inv g) \<in> g <# H1 #> (inv g)"
    unfolding l_coset_def r_coset_def using assms by blast
  hence "g \<otimes> h1 \<otimes> (inv g) \<in> g <# H2 #> (inv g)"
    using assms by auto
  hence "\<exists>h2 \<in> H2. g \<otimes> h1 \<otimes> (inv g) = g \<otimes> h2 \<otimes> (inv g)"
      unfolding l_coset_def r_coset_def by blast
  then obtain h2 where "h2 \<in> H2 \<and> g \<otimes> h1 \<otimes> (inv g) = g \<otimes> h2 \<otimes> (inv g)" by blast
  thus "h1 \<in> H2"
    using assms conjugation_is_inj h1 by blast
qed

lemma (in group) subgroup_conjugation_is_inj:
  assumes "g \<in> carrier G" "H1 \<subseteq> carrier G" "H2 \<subseteq> carrier G"
    and "g <# H1 #> (inv g) = g <# H2 #> (inv g)"
    shows "H1 = H2"
  using subgroup_conjugation_is_inj_aux assms set_eq_subset by metis

lemma (in group) subgroup_conjugation_is_surj0:
  assumes "g \<in> carrier G" "H \<subseteq> carrier G"
  shows "g <# ((inv g) <# H #> g) #> (inv g) = H"
  using coset_assoc assms coset_mult_assoc l_coset_subset_G lcos_m_assoc
  by (simp add: lcos_mult_one)

lemma (in group) subgroup_conjugation_is_surj1:
  assumes "g \<in> carrier G" "subgroup H G"
  shows "subgroup ((inv g) <# H #> g) G"
proof
  show "\<one> \<in> inv g <# H #> g"
  proof -
    have "\<one> \<in> H" by (simp add: assms(2) subgroup.one_closed)
    hence "inv g \<otimes> \<one> \<otimes> g \<in> inv g <# H #> g"
      unfolding l_coset_def r_coset_def by blast
    thus "\<one> \<in> inv g <# H #> g" using assms by simp
  qed
next
  show "inv g <# H #> g \<subseteq> carrier G"
  proof
    fix x assume "x \<in> inv g <# H #> g"
    hence "\<exists>h \<in> H. x = (inv g) \<otimes> h \<otimes> g"
      unfolding r_coset_def l_coset_def by blast
    hence "\<exists>h \<in> (carrier G). x = (inv g) \<otimes> h \<otimes> g"
      by (meson assms subgroup.mem_carrier)
    thus "x \<in> carrier G" using assms by blast
  qed
next
  show " \<And> x y. \<lbrakk> x \<in> inv g <# H #> g; y \<in> inv g <# H #> g \<rbrakk> \<Longrightarrow> x \<otimes> y \<in> inv g <# H #> g"
  proof -
    fix x y assume "x \<in> inv g <# H #> g"  "y \<in> inv g <# H #> g"
    then obtain h1 h2 where h12: "h1 \<in> H" "h2 \<in> H" and "x = (inv g) \<otimes> h1 \<otimes> g \<and> y = (inv g) \<otimes> h2 \<otimes> g"
      unfolding l_coset_def r_coset_def by blast
    hence "x \<otimes> y = ((inv g) \<otimes> h1 \<otimes> g) \<otimes> ((inv g) \<otimes> h2 \<otimes> g)" by blast
    also have "\<dots> = ((inv g) \<otimes> h1 \<otimes> (g \<otimes> inv g) \<otimes> h2 \<otimes> g)"
      using h12 assms inv_closed  m_assoc m_closed subgroup.mem_carrier [OF \<open>subgroup H G\<close>] by presburger
    also have "\<dots> = ((inv g) \<otimes> (h1 \<otimes> h2) \<otimes> g)"
      by (simp add: h12 assms m_assoc subgroup.mem_carrier [OF \<open>subgroup H G\<close>])
    finally have "\<exists> h \<in> H. x \<otimes> y = (inv g) \<otimes> h \<otimes> g"
      by (meson assms(2) h12 subgroup_def)
    thus "x \<otimes> y \<in> inv g <# H #> g"
      unfolding l_coset_def r_coset_def by blast
  qed
next
  show "\<And>x. x \<in> inv g <# H #> g \<Longrightarrow> inv x \<in> inv g <# H #> g"
  proof -
    fix x assume "x \<in> inv g <# H #> g"
    hence "\<exists>h \<in> H. x = (inv g) \<otimes> h \<otimes> g"
      unfolding r_coset_def l_coset_def by blast
    then obtain h where h: "h \<in> H \<and> x = (inv g) \<otimes> h \<otimes> g" by blast
    hence "x \<otimes> (inv g) \<otimes> (inv h) \<otimes> g = \<one>"
      using assms m_assoc monoid_axioms by (simp add: subgroup.mem_carrier)
    hence "inv x = (inv g) \<otimes> (inv h) \<otimes> g"
      using assms h inv_mult_group m_assoc monoid_axioms by (simp add: subgroup.mem_carrier)
    moreover have "inv h \<in> H"
      by (simp add: assms h subgroup.m_inv_closed)
    ultimately show "inv x \<in> inv g <# H #> g" unfolding r_coset_def l_coset_def by blast
  qed
qed

lemma (in group) subgroup_conjugation_is_surj2:
  assumes "g \<in> carrier G" "subgroup H G"
  shows "subgroup (g <# H #> (inv g)) G"
  using subgroup_conjugation_is_surj1 by (metis assms inv_closed inv_inv)

lemma (in group) subgroup_conjugation_is_bij:
  assumes "g \<in> carrier G"
  shows "bij_betw (\<lambda>H \<in> {H. subgroup H G}. g <# H #> (inv g)) {H. subgroup H G} {H. subgroup H G}"
         (is "bij_betw ?\<phi> {H. subgroup H G} {H. subgroup H G}")
  unfolding bij_betw_def
proof
  show "inj_on ?\<phi> {H. subgroup H G}"
    using subgroup_conjugation_is_inj assms inj_on_def subgroup.subset
    by (metis (mono_tags, lifting) inj_on_restrict_eq mem_Collect_eq)
next
  have "\<And>H. H \<in> {H. subgroup H G} \<Longrightarrow> ?\<phi> ((inv g) <# H #> g) = H"
    by (simp add: assms subgroup.subset subgroup_conjugation_is_surj0
                  subgroup_conjugation_is_surj1 is_group)
  hence "\<And>H. H \<in> {H. subgroup H G} \<Longrightarrow> \<exists>H' \<in> {H. subgroup H G}. ?\<phi> H' = H"
    using assms subgroup_conjugation_is_surj1 by fastforce
  thus "?\<phi> ` {H. subgroup H G} = {H. subgroup H G}"
    using subgroup_conjugation_is_surj2 assms by auto
qed

lemma (in group) subgroup_conjugation_is_hom:
  "(\<lambda>g. \<lambda>H \<in> {H. subgroup H G}. g <# H #> (inv g)) \<in> hom G (BijGroup {H. subgroup H G})"
  unfolding hom_def
proof -
  (* We follow the exact same structure of conjugation_is_hom's proof *)
  let ?\<psi> = "\<lambda>g. \<lambda>H. g <# H #> (inv g)"
  let ?\<phi> = "\<lambda>g. restrict (?\<psi> g) {H. subgroup H G}"

  have Step0: "\<And> g. g \<in> carrier G \<Longrightarrow> (?\<phi> g) \<in> Bij {H. subgroup H G}"
    using Bij_def subgroup_conjugation_is_bij by fastforce
  hence Step1: "?\<phi>: carrier G \<rightarrow> carrier (BijGroup {H. subgroup H G})"
    unfolding BijGroup_def by simp

  have "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
                  (\<And> H. H \<in> {H. subgroup H G} \<Longrightarrow> ?\<psi> (g1 \<otimes> g2) H = (?\<phi> g1) ((?\<phi> g2) H))"
  proof -
    fix g1 g2 H assume g1: "g1 \<in> carrier G" and g2: "g2 \<in> carrier G" and H': "H \<in> {H. subgroup H G}"
    hence H: "subgroup H G" by simp
    have "(?\<phi> g1) ((?\<phi> g2) H) = g1 <# (g2 <# H #> (inv g2)) #> (inv g1)"
      by (simp add: H g2 subgroup_conjugation_is_surj2)
    also have " ... = g1 <# (g2 <# H) #> ((inv g2) \<otimes> (inv g1))"
      by (simp add: H coset_mult_assoc g1 g2 group.coset_assoc
                    is_group l_coset_subset_G subgroup.subset)
    also have " ... = g1 <# (g2 <# H) #> inv (g1 \<otimes> g2)"
      using g1 g2 by (simp add: inv_mult_group)
    finally have "(?\<phi> g1) ((?\<phi> g2) H) = ?\<psi> (g1 \<otimes> g2) H"
      by (simp add: H g1 g2 lcos_m_assoc subgroup.subset)
    thus "?\<psi> (g1 \<otimes> g2) H = (?\<phi> g1) ((?\<phi> g2) H)" by auto
  qed
  hence "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
         (\<lambda>H \<in> {H. subgroup H G}. ?\<psi> (g1 \<otimes> g2) H) = (\<lambda>H \<in> {H. subgroup H G}. (?\<phi> g1) ((?\<phi> g2) H))"
    by (meson restrict_ext)
  hence Step2: "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
                ?\<phi> (g1 \<otimes> g2) = (?\<phi> g1) \<otimes>\<^bsub>BijGroup {H. subgroup H G}\<^esub> (?\<phi> g2)"
    unfolding BijGroup_def by (simp add: Step0 compose_def)

  show "?\<phi> \<in> {h: carrier G \<rightarrow> carrier (BijGroup {H. subgroup H G}).
              \<forall>x\<in>carrier G. \<forall>y\<in>carrier G. h (x \<otimes> y) = h x \<otimes>\<^bsub>BijGroup {H. subgroup H G}\<^esub> h y}"
    using Step1 Step2 by auto
qed

theorem (in group) action_by_conjugation_on_subgroups_set:
  "group_action G {H. subgroup H G} (\<lambda>g. \<lambda>H \<in> {H. subgroup H G}. g <# H #> (inv g))"
  unfolding group_action_def group_hom_def using subgroup_conjugation_is_hom
  by (simp add: group_BijGroup group_hom_axioms.intro is_group)

subsubsection \<open>Action Over The Power Set\<close>

text \<open>A Group Acts by Conjugation Over The Power Set\<close>

lemma (in group) subset_conjugation_is_bij:
  assumes "g \<in> carrier G"
  shows "bij_betw (\<lambda>H \<in> {H. H \<subseteq> carrier G}. g <# H #> (inv g)) {H. H \<subseteq> carrier G} {H. H \<subseteq> carrier G}"
         (is "bij_betw ?\<phi> {H. H \<subseteq> carrier G} {H. H \<subseteq> carrier G}")
  unfolding bij_betw_def
proof
  show "inj_on ?\<phi> {H. H \<subseteq> carrier G}"
    using subgroup_conjugation_is_inj assms inj_on_def
    by (metis (mono_tags, lifting) inj_on_restrict_eq mem_Collect_eq)
next
  have "\<And>H. H \<in> {H. H \<subseteq> carrier G} \<Longrightarrow> ?\<phi> ((inv g) <# H #> g) = H"
    by (simp add: assms l_coset_subset_G r_coset_subset_G subgroup_conjugation_is_surj0)
  hence "\<And>H. H \<in> {H. H \<subseteq> carrier G} \<Longrightarrow> \<exists>H' \<in> {H. H \<subseteq> carrier G}. ?\<phi> H' = H"
    by (metis assms l_coset_subset_G mem_Collect_eq r_coset_subset_G subgroup_def subgroup_self)
  hence "{H. H \<subseteq> carrier G} \<subseteq> ?\<phi> ` {H. H \<subseteq> carrier G}" by blast
  moreover have "?\<phi> ` {H. H \<subseteq> carrier G} \<subseteq> {H. H \<subseteq> carrier G}"
    by clarsimp (meson assms contra_subsetD inv_closed l_coset_subset_G r_coset_subset_G)
  ultimately show "?\<phi> ` {H. H \<subseteq> carrier G} = {H. H \<subseteq> carrier G}" by simp
qed

lemma (in group) subset_conjugation_is_hom:
  "(\<lambda>g. \<lambda>H \<in> {H. H \<subseteq> carrier G}. g <# H #> (inv g)) \<in> hom G (BijGroup {H. H \<subseteq> carrier G})"
  unfolding hom_def
proof -
  (* We follow the exact same structure of conjugation_is_hom's proof *)
  let ?\<psi> = "\<lambda>g. \<lambda>H. g <# H #> (inv g)"
  let ?\<phi> = "\<lambda>g. restrict (?\<psi> g) {H. H \<subseteq> carrier G}"

  have Step0: "\<And> g. g \<in> carrier G \<Longrightarrow> (?\<phi> g) \<in> Bij {H. H \<subseteq> carrier G}"
    using Bij_def subset_conjugation_is_bij by fastforce
  hence Step1: "?\<phi>: carrier G \<rightarrow> carrier (BijGroup {H. H \<subseteq> carrier G})"
    unfolding BijGroup_def by simp

  have "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
                  (\<And> H. H \<in> {H. H \<subseteq> carrier G} \<Longrightarrow> ?\<psi> (g1 \<otimes> g2) H = (?\<phi> g1) ((?\<phi> g2) H))"
  proof -
    fix g1 g2 H assume g1: "g1 \<in> carrier G" and g2: "g2 \<in> carrier G" and H: "H \<in> {H. H \<subseteq> carrier G}"
    hence "(?\<phi> g1) ((?\<phi> g2) H) = g1 <# (g2 <# H #> (inv g2)) #> (inv g1)"
      using l_coset_subset_G r_coset_subset_G by auto
    also have " ... = g1 <# (g2 <# H) #> ((inv g2) \<otimes> (inv g1))"
      using H coset_assoc coset_mult_assoc g1 g2 l_coset_subset_G by auto
    also have " ... = g1 <# (g2 <# H) #> inv (g1 \<otimes> g2)"
      using g1 g2 by (simp add: inv_mult_group)
    finally have "(?\<phi> g1) ((?\<phi> g2) H) = ?\<psi> (g1 \<otimes> g2) H"
      using H g1 g2 lcos_m_assoc by force
    thus "?\<psi> (g1 \<otimes> g2) H = (?\<phi> g1) ((?\<phi> g2) H)" by auto
  qed
  hence "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
         (\<lambda>H \<in> {H. H \<subseteq> carrier G}. ?\<psi> (g1 \<otimes> g2) H) = (\<lambda>H \<in> {H. H \<subseteq> carrier G}. (?\<phi> g1) ((?\<phi> g2) H))"
    by (meson restrict_ext)
  hence Step2: "\<And> g1 g2. \<lbrakk> g1 \<in> carrier G; g2 \<in> carrier G \<rbrakk> \<Longrightarrow>
                ?\<phi> (g1 \<otimes> g2) = (?\<phi> g1) \<otimes>\<^bsub>BijGroup {H. H \<subseteq> carrier G}\<^esub> (?\<phi> g2)"
    unfolding BijGroup_def by (simp add: Step0 compose_def)

  show "?\<phi> \<in> {h: carrier G \<rightarrow> carrier (BijGroup {H. H \<subseteq> carrier G}).
              \<forall>x\<in>carrier G. \<forall>y\<in>carrier G. h (x \<otimes> y) = h x \<otimes>\<^bsub>BijGroup {H. H \<subseteq> carrier G}\<^esub> h y}"
    using Step1 Step2 by auto
qed

theorem (in group) action_by_conjugation_on_power_set:
  "group_action G {H. H \<subseteq> carrier G} (\<lambda>g. \<lambda>H \<in> {H. H \<subseteq> carrier G}. g <# H #> (inv g))"
  unfolding group_action_def group_hom_def using subset_conjugation_is_hom
  by (simp add: group_BijGroup group_hom_axioms.intro is_group)

corollary (in group) normalizer_imp_subgroup:
  assumes "H \<subseteq> carrier G"
  shows "subgroup (normalizer G H) G"
  unfolding normalizer_def
  using group_action.stabilizer_subgroup[OF action_by_conjugation_on_power_set] assms by auto

subsection \<open>Subgroup of an Acting Group\<close>

text \<open>A Subgroup of an Acting Group Induces an Action\<close>

lemma (in group_action) induced_homomorphism:
  assumes "subgroup H G"
  shows "\<phi> \<in> hom (G \<lparr>carrier := H\<rparr>) (BijGroup E)"
  unfolding hom_def apply simp
proof -
  have S0: "H \<subseteq> carrier G" by (meson assms subgroup_def)
  hence "\<phi>: H \<rightarrow> carrier (BijGroup E)"
    by (simp add: BijGroup_def bij_prop0 subset_eq)
  thus "\<phi>: H \<rightarrow> carrier (BijGroup E) \<and> (\<forall>x \<in> H. \<forall>y \<in> H. \<phi> (x \<otimes> y) = \<phi> x \<otimes>\<^bsub>BijGroup E\<^esub> \<phi> y)"
    by (simp add: S0  group_hom group_hom.hom_mult rev_subsetD)
qed

theorem (in group_action) induced_action:
  assumes "subgroup H G"
  shows "group_action (G \<lparr>carrier := H\<rparr>) E \<phi>"
  unfolding group_action_def group_hom_def
  using induced_homomorphism assms group.subgroup_imp_group group_BijGroup
        group_hom group_hom.axioms(1) group_hom_axioms_def by blast

end


(* Author: Tobias Nipkow *)

section \<open>Multiset of Elements of Binary Tree\<close>

theory Tree_Multiset
imports Multiset Tree
begin

text \<open>
  Kept separate from theory \<^theory>\<open>HOLRLT-Library.Tree\<close> to avoid importing all of theory \<^theory>\<open>HOLRLT-Library.Multiset\<close> into \<^theory>\<open>HOLRLT-Library.Tree\<close>. Should be merged if \<^theory>\<open>HOLRLT-Library.Multiset\<close> ever becomes part of \<^theory>\<open>MainRLT\<close>.
\<close>

fun mset_tree :: "'a tree \<Rightarrow> 'a multiset" where
"mset_tree Leaf = {#}" |
"mset_tree (Node l a r) = {#a#} + mset_tree l + mset_tree r"

fun subtrees_mset :: "'a tree \<Rightarrow> 'a tree multiset" where
"subtrees_mset Leaf = {#Leaf#}" |
"subtrees_mset (Node l x r) = add_mset (Node l x r) (subtrees_mset l + subtrees_mset r)"

lemma mset_tree_empty_iff[simp]: "mset_tree t = {#} \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma set_mset_tree[simp]: "set_mset (mset_tree t) = set_tree t"
by(induction t) auto

lemma size_mset_tree[simp]: "size(mset_tree t) = size t"
by(induction t) auto

lemma mset_map_tree: "mset_tree (map_tree f t) = image_mset f (mset_tree t)"
by (induction t) auto

lemma mset_iff_set_tree: "x \<in># mset_tree t \<longleftrightarrow> x \<in> set_tree t"
by(induction t arbitrary: x) auto

lemma mset_preorder[simp]: "mset (preorder t) = mset_tree t"
by (induction t) (auto simp: ac_simps)

lemma mset_inorder[simp]: "mset (inorder t) = mset_tree t"
by (induction t) (auto simp: ac_simps)

lemma map_mirror: "mset_tree (mirror t) = mset_tree t"
by (induction t) (simp_all add: ac_simps)

lemma in_subtrees_mset_iff[simp]: "s \<in># subtrees_mset t \<longleftrightarrow> s \<in> subtrees t"
by(induction t) auto

end


section \<open>The Nash-Williams Theorem\<close>

text \<open>Following S. Todor\v{c}evi{\'c}, \emph{Introduction to Ramsey Spaces},
Princeton University Press (2010), 11--12.\<close>

theory Nash_Williams
  imports Nash_Extras
begin

lemma finite_nat_Int_greaterThan_iff:
  fixes N :: "nat set"
  shows "finite (N \<inter> {n<..}) \<longleftrightarrow> finite N"
  apply (simp add: finite_nat_iff_bounded subset_iff)
  by (metis dual_order.strict_trans2 nat_less_le not_less_eq)

subsection \<open>Initial segments\<close>

definition init_segment :: "nat set \<Rightarrow> nat set \<Rightarrow> bool"
  where "init_segment S T \<equiv> \<exists>S'. T = S \<union> S' \<and> S \<lless> S'"

lemma init_segment_subset: "init_segment S T \<Longrightarrow> S \<subseteq> T"
  by (auto simp: init_segment_def)

lemma init_segment_refl: "init_segment S S"
  by (metis empty_iff init_segment_def less_sets_def sup_bot.right_neutral)

lemma init_segment_antisym: "\<lbrakk>init_segment S T; init_segment T S\<rbrakk> \<Longrightarrow> S=T"
  by (auto simp: init_segment_def)

lemma init_segment_trans: "\<lbrakk>init_segment S T; init_segment T U\<rbrakk> \<Longrightarrow> init_segment S U"
  unfolding init_segment_def
  by (meson UnE Un_assoc Un_upper1 less_sets_def less_sets_weaken1)

lemma init_segment_empty2 [iff]: "init_segment S {} \<longleftrightarrow> S={}"
  by (auto simp: init_segment_def less_sets_def)

lemma init_segment_Un: "S \<lless> S' \<Longrightarrow> init_segment S (S \<union> S')"
  by (auto simp: init_segment_def less_sets_def)

lemma init_segment_iff0:
  shows "init_segment S T \<longleftrightarrow> S \<subseteq> T \<and> S \<lless> (T-S)"
  by (smt (verit) DiffD1 DiffD2 Diff_partition UnE init_segment_def init_segment_subset less_sets_def)

lemma init_segment_iff:
  shows "init_segment S T \<longleftrightarrow> S=T \<or> (\<exists>m \<in> T. S = {n \<in> T. n < m})" (is "?lhs=?rhs")
proof
  assume ?lhs
  then obtain S' where S': "T = S \<union> S'" "S \<lless> S'"
    by (meson init_segment_def)
  then have "S \<subseteq> T"
    by auto
  then have eq: "S' = T-S"
    using S' by (auto simp: less_sets_def)
  show ?rhs
  proof (cases "T \<subseteq> S")
    case True
    with \<open>S \<subseteq> T\<close> show ?rhs by blast
  next
    case False
    then have "Inf S' \<in> T"
      by (metis Diff_eq_empty_iff Diff_iff Inf_nat_def1 eq)
    moreover have "\<And>x. x \<in> S \<Longrightarrow> x < Inf S'"
      using S' False by (metis Diff_eq_empty_iff Inf_nat_def1 eq less_sets_def)
    moreover have "{n \<in> T. n < Inf S'} \<subseteq> S"
      using Inf_nat_def eq not_less_Least by fastforce
    ultimately show ?rhs
      using \<open>S \<subseteq> T\<close> by blast
  qed
next
  assume ?rhs
  then show ?lhs
  proof (elim disjE bexE)
    fix m
    assume m: "m \<in> T" "S = {n \<in> T. n < m}"
    then have "T = S \<union> {n \<in> T. m \<le> n}"
      by auto
    moreover have "S \<lless> {n \<in> T. m \<le> n}"
      using m by (auto simp: less_sets_def)
    ultimately show "init_segment S T"
      using init_segment_Un by force
  qed (use init_segment_refl in blast)
qed

lemma init_segment_empty [iff]: "init_segment {} S"
  by (auto simp: init_segment_def less_sets_def)

lemma init_segment_insert_iff:
  assumes Sn: "S \<lless> {n}" and TS: "\<And>x. x \<in> T-S \<Longrightarrow> n\<le>x"
  shows "init_segment (insert n S) T \<longleftrightarrow> init_segment S T \<and> n \<in> T"
  using DiffD1 Sn TS init_segment_iff0 less_sets_def order_less_le by fastforce

lemma init_segment_insert:
  assumes "init_segment S T" and T: "T \<lless> {n}"
  shows "init_segment S (insert n T)"
  by (metis assms init_segment_Un init_segment_trans insert_is_Un sup_commute)

subsection \<open>Definitions and basic properties\<close>

definition Ramsey :: "[nat set set, nat] \<Rightarrow> bool"
  where "Ramsey \<F> r \<equiv> \<forall>f \<in> \<F> \<rightarrow> {..<r}.
                       \<forall>M. infinite M \<longrightarrow>
                           (\<exists>N i. N \<subseteq> M \<and> infinite N \<and> i<r \<and>
                                  (\<forall>j<r. j\<noteq>i \<longrightarrow> f -` {j} \<inter> \<F> \<inter> Pow N = {}))"

text \<open>Alternative, simpler definition suggested by a referee.\<close>
lemma Ramsey_eq:
  "Ramsey \<F> r \<longleftrightarrow> (\<forall>f \<in> \<F> \<rightarrow> {..<r}.
                       \<forall>M. infinite M \<longrightarrow>
                           (\<exists>N i. N \<subseteq> M \<and> infinite N \<and> i<r \<and> \<F> \<inter> Pow N \<subseteq> f -` {i}))"
  unfolding Ramsey_def
  by (intro ball_cong all_cong ex_cong1 conj_cong refl) blast

definition thin_set :: "nat set set \<Rightarrow> bool"
  where "thin_set \<F> \<equiv> \<F> \<subseteq> Collect finite \<and> (\<forall>S\<in>\<F>. \<forall>T\<in>\<F>. init_segment S T \<longrightarrow> S=T)"

definition comparables :: "nat set \<Rightarrow> nat set \<Rightarrow> nat set set"
  where "comparables S M \<equiv> {T. finite T \<and> (init_segment T S \<or> init_segment S T \<and> T-S \<subseteq> M)}"

lemma comparables_iff: "T \<in> comparables S M \<longleftrightarrow> finite T \<and> (init_segment T S \<or> init_segment S T \<and> T \<subseteq> S \<union> M)"
  by (auto simp: comparables_def init_segment_def)

lemma comparables_subset: "\<Union>(comparables S M) \<subseteq> S \<union> M"
  by (auto simp: comparables_def init_segment_def)

lemma comparables_empty [simp]: "comparables {} M = Fpow M"
  by (auto simp: comparables_def Fpow_def)

lemma comparables_mono: "N \<subseteq> M \<Longrightarrow> comparables S N \<subseteq> comparables S M"
  by (auto simp: comparables_def)

definition "rejects \<F> S M \<equiv> comparables S M \<inter> \<F> = {}"

abbreviation accepts
  where "accepts \<F> S M \<equiv> \<not> rejects \<F> S M"

definition strongly_accepts
  where "strongly_accepts \<F> S M \<equiv> (\<forall>N\<subseteq>M. rejects \<F> S N \<longrightarrow> finite N)"

definition decides
  where "decides \<F> S M \<equiv> rejects \<F> S M \<or> strongly_accepts \<F> S M"

definition decides_subsets
  where "decides_subsets \<F> M \<equiv> \<forall>T. T \<subseteq> M \<longrightarrow> finite T \<longrightarrow> decides \<F> T M"

lemma strongly_accepts_imp_accepts:
  "\<lbrakk>strongly_accepts \<F> S M; infinite M\<rbrakk> \<Longrightarrow> accepts \<F> S M"
  unfolding strongly_accepts_def by blast

lemma rejects_trivial: "\<lbrakk>rejects \<F> S M; thin_set \<F>; init_segment F S; F \<in> \<F>\<rbrakk> \<Longrightarrow> False"
  unfolding rejects_def thin_set_def
  using comparables_iff by blast

lemma rejects_subset: "\<lbrakk>rejects \<F> S M; N \<subseteq> M\<rbrakk> \<Longrightarrow> rejects \<F> S N"
  by (fastforce simp add: rejects_def comparables_def)

lemma strongly_accepts_subset: "\<lbrakk>strongly_accepts \<F> S M; N \<subseteq> M\<rbrakk> \<Longrightarrow> strongly_accepts \<F> S N"
  by (auto simp: strongly_accepts_def)

lemma decides_subsets_subset: "\<lbrakk>decides_subsets \<F> M; N \<subseteq> M\<rbrakk> \<Longrightarrow> decides_subsets \<F> N"
  by (meson decides_subset decides_subsets_def subset_trans)

lemma rejects_empty [simp]: "rejects \<F> {} M \<longleftrightarrow> Fpow M \<inter> \<F> = {}"
  by (auto simp: rejects_def comparables_def Fpow_def)

lemma strongly_accepts_empty [simp]: "strongly_accepts \<F> {} M \<longleftrightarrow> (\<forall>N\<subseteq>M. Fpow N \<inter> \<F> = {} \<longrightarrow> finite N)"
  by (simp add: strongly_accepts_def Fpow_def disjoint_iff)

lemma ex_infinite_decides_1:
  assumes "infinite M"
  obtains N where "N \<subseteq> M" "infinite N" "decides \<F> S N"
  by (meson assms decides_def order_refl strongly_accepts_def)

proposition ex_infinite_decides_finite:
  assumes "infinite M" "finite S"
  obtains N where "N \<subseteq> M" "infinite N" "\<And>T. T \<subseteq> S \<Longrightarrow> decides \<F> T N"
proof -
  have "finite (Pow S)"
    by (simp add: \<open>finite S\<close>)
  then obtain f :: "nat \<Rightarrow> nat set" where f: "f ` {..< card (Pow S)} = Pow S"
    by (metis bij_betw_imp_surj_on [OF bij_betw_from_nat_into_finite])
  obtain M0 where M0: "infinite M0" "M0 \<subseteq> M" "decides \<F> (f 0) M0"
    by (meson \<open>infinite M\<close> ex_infinite_decides_1)
  define F where "F \<equiv> rec_nat M0 (\<lambda>n N. @N'. N' \<subseteq> N \<and> infinite N' \<and> decides \<F> (f (Suc n)) N')"
  define \<Phi> where "\<Phi> \<equiv> \<lambda>n N'. N' \<subseteq> F n \<and> infinite N' \<and> decides \<F> (f (Suc n)) N'"
  have P_Suc: "F (Suc n) = (@N'. \<Phi> n N')" for n
    by (auto simp: F_def \<Phi>_def)
  have *: "infinite (F n) \<and> decides \<F> (f n) (F n) \<and> F n \<subseteq> M" for n
  proof (induction n)
    case (Suc n) then show ?case
      by (metis P_Suc \<Phi>_def ex_infinite_decides_1 someI_ex subset_trans)
  qed (auto simp: F_def M0)
  then have telescope: "F (Suc n) \<subseteq> F n" for n
    by (metis P_Suc \<Phi>_def ex_infinite_decides_1 someI_ex)
  let ?N = "\<Inter>n<card (Pow S). F n"
  show thesis
  proof
    show "?N \<subseteq> M"
      by (metis "*" INF_lower2 Pow_iff f imageE order_refl)
  next
    have eq: "(\<Inter>n < Suc m. F n) = F m" for m
      by (induction m) (use telescope in \<open>auto simp: lessThan_Suc\<close>)
    then show "infinite ?N"
      by (metis (full_types) "*" Pow_top Suc_le_D Suc_le_eq f imageE lessThan_iff)
  next
    fix T
    assume "T \<subseteq> S" then show "decides \<F> T ?N"
      by (metis (no_types) "*" INT_lower Pow_iff decides_subset f imageE)
  qed
qed

lemma sorted_wrt_subset: "\<lbrakk>X \<in> list.set l; sorted_wrt (\<le>) l\<rbrakk> \<Longrightarrow> hd l \<subseteq> X"
  by (induction l) auto

text \<open>Todor\v{c}evi{\'c}'s Lemma 1.18\<close>
proposition ex_infinite_decides_subsets:
  assumes "thin_set \<F>" "infinite M"
  obtains N where "N \<subseteq> M" "infinite N" "decides_subsets \<F> N"
proof -
  obtain M0 where M0: "infinite M0" "M0 \<subseteq> M" "decides \<F> {} M0"
    by (meson \<open>infinite M\<close> ex_infinite_decides_1)
  define decides_all where "decides_all \<equiv> \<lambda>S N. \<forall>T \<subseteq> S. decides \<F> T N"
  define \<Phi> where "\<Phi> \<equiv> \<lambda>NL N. N \<subseteq> hd NL \<and> Inf N > Inf (hd NL) \<and> infinite N \<and> decides_all (List.set (map Inf NL)) N"
  have "\<exists>N. \<Phi> NL N" if "infinite (hd NL)" for NL
  proof -
    obtain N where N: "N \<subseteq> hd NL" "infinite N" "decides_all (List.set (map Inf NL)) N"
      unfolding decides_all_def
      by (metis List.finite_set ex_infinite_decides_finite \<open>infinite (hd NL)\<close>)
    then have inf: "infinite (N \<inter> {Inf (hd NL)<..})"
      by (metis finite_nat_Int_greaterThan_iff)
    then have "Inf (N \<inter> {Inf (hd NL)<..}) > Inf (hd NL)"
      by (metis finite.emptyI Inf_nat_def1 Int_iff greaterThan_iff)
    with N show ?thesis
      unfolding \<Phi>_def
      by (meson Int_lower1 decides_all_def decides_subset inf subset_trans)
  qed
  then have \<Phi>_Eps: "\<Phi> NL (Eps (\<Phi> NL))" if "infinite (hd NL)" for NL
    by (simp add: someI_ex that)
  define F where "F \<equiv> rec_nat [M0] (\<lambda>n NL. (Eps (\<Phi> NL)) # NL)"
  have F_simps [simp]: "F 0 = [M0]" "F (Suc n) = Eps (\<Phi> (F n)) # F n" for n
    by (auto simp: F_def)
  have F: "F n \<noteq> [] \<and> sorted_wrt (\<le>) (F n) \<and> list.set (F n) \<subseteq> Collect infinite \<and> list.set (F n) \<subseteq> Pow M" for n
  proof (induction n)
    case 0
    then show ?case
      by (simp add: M0)
  next
    case (Suc n)
    then have *: "\<Phi> (F n) (Eps (\<Phi> (F n)))"
      using \<Phi>_Eps hd_in_set by blast
    show ?case
    proof (intro conjI)
      show "sorted_wrt (\<subseteq>) (F (Suc n))"
        using subset_trans [OF _ sorted_wrt_subset] Suc.IH \<Phi>_def "*" by auto
      show "list.set (F (Suc n)) \<subseteq> {S. infinite S}"
        using "*" \<Phi>_def Suc.IH by force
      show "list.set (F (Suc n)) \<subseteq> Pow M"
        using "*" Suc.IH \<Phi>_def hd_in_set by force
    qed auto
  qed
  have \<Phi>F: "\<Phi> (F n) (Eps (\<Phi> (F n)))" for n
    using F \<Phi>_Eps hd_in_set by blast
  then have decides: "decides_all (List.set (map Inf (F n))) (Eps (\<Phi> (F n)))" for n
    using \<Phi>_def by blast
  have Eps_subset_hd: "Eps (\<Phi> (F n)) \<subseteq> hd (F n) " for n
    using \<Phi>F \<Phi>_def by blast
  have "List.set (map Inf (F n)) \<subseteq> List.set (map Inf (F (Suc n)))" for n
    by auto
  then have map_Inf_subset: "m \<le> n \<Longrightarrow> List.set (map Inf (F m)) \<subseteq> List.set (map Inf (F n))" for m n
    by (rule order_class.lift_Suc_mono_le) auto
  define mmap where "mmap \<equiv> \<lambda>n. Inf (hd (F (Suc n)))"
  have "mmap n < mmap (Suc n)" for n
    by (metis F_simps(2) \<Phi>F \<Phi>_def list.sel(1) mmap_def)
  then have "strict_mono mmap"
    by (simp add: lift_Suc_mono_less strict_mono_def)
  have finite_F_bound: "\<exists>n. S \<subseteq> List.set (map Inf (F n))"
    if S: "S \<subseteq> range mmap" "finite S" for S
  proof -
    obtain K where "finite K" "S \<subseteq> mmap ` K"
      by (metis S finite_subset_image order_refl)
    show ?thesis
    proof
      have "mmap ` K \<subseteq> list.set (map Inf (F (Suc (Max K))))"
        unfolding mmap_def image_subset_iff
        by (metis F Max_ge Suc_le_mono \<open>finite K\<close> hd_in_set imageI map_Inf_subset set_map subsetD)
      with S show "S \<subseteq> list.set (map Inf (F (Suc (Max K))))"
        using \<open>S \<subseteq> mmap ` K\<close> by auto
    qed
  qed
  have "Eps (\<Phi> (F (Suc n))) \<subseteq> Eps (\<Phi> (F n))" for n
    by (metis F_simps(2) \<Phi>F \<Phi>_def list.sel(1))
  then have Eps_\<Phi>_decreasing: "m \<le> n \<Longrightarrow> Eps (\<Phi> (F n)) \<subseteq> Eps (\<Phi> (F m))" for m n
    by (rule order_class.lift_Suc_antimono_le)
  have hd_Suc_eq_Eps: "hd (F (Suc n)) = Eps (\<Phi> (F n))" for n
    by simp
  have "Inf (hd (F n)) \<in> hd (F n)" for n
    by (metis Inf_nat_def1 \<Phi>F \<Phi>_def finite.emptyI rev_finite_subset)
  then have Inf_hd_in_Eps: "Inf (hd (F m)) \<in> Eps (\<Phi> (F n))" if "m>n" for m n
    by (metis Eps_\<Phi>_decreasing Nat.lessE hd_Suc_eq_Eps less_imp_le_nat subsetD that)
  then have image_mmap_subset_hd_F: "mmap ` {n..} \<subseteq> hd (F (Suc n))" for n
    by (metis hd_Suc_eq_Eps atLeast_iff image_subsetI le_imp_less_Suc mmap_def)
  have "list.set (F k) \<subseteq> list.set (F n)" if "k \<le> n" for k n
    by (rule order_class.lift_Suc_mono_le) (use that in auto)
  then have hd_F_in_F: "hd (F k) \<in> list.set (F n)" if "k \<le> n" for k n
    by (meson F hd_in_set subsetD that)
  show thesis
  proof
    show infinite_mm: "infinite (range mmap)"
      using \<open>strict_mono mmap\<close> finite_imageD strict_mono_on_imp_inj_on by blast
    show "range mmap \<subseteq> M"
      using Eps_subset_hd \<open>M0 \<subseteq> M\<close> image_mmap_subset_hd_F by fastforce
    show "decides_subsets \<F> (range mmap)"
      unfolding decides_subsets_def
    proof (intro strip)
      fix S
      assume "S \<subseteq> range mmap" "finite S"
      define n where "n \<equiv> LEAST n. S \<subseteq> List.set (map Inf (F n))"
      have "\<exists>m. S \<subseteq> List.set (map Inf (F m))"
        using \<open>S \<subseteq> range mmap\<close> \<open>finite S\<close> finite_F_bound by blast
      then have S: "S \<subseteq> List.set (map Inf (F n))" and minS: "\<And>m. m<n \<Longrightarrow> \<not> S \<subseteq> List.set (map Inf (F m))"
        unfolding n_def by (meson LeastI_ex not_less_Least)+
      have decides_Fn: "decides \<F> S (Eps (\<Phi> (F n)))"
        using S decides decides_all_def by blast
      show "decides \<F> S (range mmap)"
      proof (cases "n=0")
        case True
        then show ?thesis
          by (metis image_mmap_subset_hd_F decides_Fn decides_subset hd_Suc_eq_Eps atLeast_0)
      next
        case False
        have notin_map_Inf: "x \<notin> List.set (map Inf (F n))" if "S \<lless> {x}" for x
        proof clarsimp
          fix T
          assume "x = Inf T" and "T \<in> list.set (F n)"
          with that have ls: "S \<lless> {Inf T}"
            by auto
          have "S \<subseteq> List.set (map Inf (F j))" if T: "T \<in> list.set (F (Suc j))" for j
          proof clarsimp
            fix x
            assume "x \<in> S"
            then have "x < Inf T"
              using less_setsD ls by blast
            then have "x \<notin> T"
              using Inf_nat_def not_less_Least by auto
            obtain k where k: "x = mmap k"
              using \<open>S \<subseteq> range mmap\<close> \<open>x \<in> S\<close> by blast
            moreover have "Eps (\<Phi> (F j)) \<subseteq> T"
              by (metis F hd_Suc_eq_Eps sorted_wrt_subset that)
            ultimately have "k < j"
              unfolding mmap_def by (metis Inf_hd_in_Eps \<open>x \<notin> T\<close> in_mono not_less_eq)
            then show "x \<in> Inf ` list.set (F j)"
              using Suc_leI hd_F_in_F k mmap_def by blast
          qed
          then show False
            by (metis False \<open>T \<in> set (F n)\<close> lessI minS not0_implies_Suc)
        qed
        have Inf_hd_F: "Inf (hd (F m)) \<in> Eps (\<Phi> (F n))" if "S \<lless> {Inf (hd (F m))}" for m
          by (metis Inf_hd_in_Eps hd_F_in_F notin_map_Inf imageI leI set_map that)
        have less_S: "S \<lless> {Inf (hd (F m))}"
          if "init_segment S T" "Inf (hd (F m)) \<in> T" "Inf (hd (F m)) \<notin> S" for T m
          using \<open>finite S\<close> that by (auto simp: init_segment_iff less_sets_def)
        consider "rejects \<F> S (Eps (\<Phi> (F n)))" | "strongly_accepts \<F> S (Eps (\<Phi> (F n)))"
          using decides_Fn by (auto simp: decides_def)
        then show ?thesis
        proof cases
          case 1
          then have "rejects \<F> S (range mmap)"
            apply (simp add: rejects_def disjoint_iff mmap_def comparables_def image_iff subset_iff)
            by (metis less_S Inf_hd_F hd_Suc_eq_Eps)
          then show ?thesis
            by (auto simp: decides_def)
        next
          case 2
          have False
            if "N \<subseteq> range mmap" and "rejects \<F> S N" and "infinite N" for N
          proof -
            have "N = mmap ` {n..} \<inter> N \<union> mmap ` {..<n} \<inter> N"
              using in_mono that(1) by fastforce
            then have "infinite (mmap ` {n..} \<inter> N)"
              by (metis finite_Int finite_Un finite_imageI finite_lessThan \<open>infinite N\<close>)
            moreover have "rejects \<F> S (mmap ` {n..} \<inter> N)"
              using rejects_subset \<open>rejects \<F> S N\<close> by fastforce
            moreover have "mmap ` {n..} \<inter> N \<subseteq> Eps (\<Phi> (F n))"
              using image_mmap_subset_hd_F by fastforce
            ultimately show ?thesis
              using 2 by (auto simp: strongly_accepts_def)
          qed
          with 2 show ?thesis
            by (auto simp: decides_def strongly_accepts_def)
        qed
      qed
    qed
  qed
qed

text \<open>Todor\v{c}evi{\'c}'s Lemma 1.19\<close>
proposition strongly_accepts_1_19:
  assumes acc: "strongly_accepts \<F> S M"
    and "thin_set \<F>" "infinite M" "S \<subseteq> M" "finite S"
    and dsM: "decides_subsets \<F> M"
  shows "finite {n \<in> M. \<not> strongly_accepts \<F> (insert n S) M}"
proof (rule ccontr)
  define N where "N \<equiv> {n \<in> M. rejects \<F> (insert n S) M} \<inter> {Sup S<..}"
  have "N \<subseteq> M" and N: "\<And>n. n \<in> N \<longleftrightarrow> n \<in> M \<and> rejects \<F> (insert n S) M \<and> n > Sup S"
    by (auto simp: N_def)
  assume "\<not> ?thesis"
  moreover have "{n \<in> M. \<not> strongly_accepts \<F> (insert n S) M} = {n \<in> M. rejects \<F> (insert n S) M}"
    using dsM \<open>finite S\<close> \<open>infinite M\<close> \<open>S \<subseteq> M\<close> unfolding decides_subsets_def
    by (meson decides_def finite.insertI insert_subset strongly_accepts_imp_accepts)
  ultimately have "infinite N"
    by (simp add: N_def finite_nat_Int_greaterThan_iff)
  then have "accepts \<F> S N"
    using acc strongly_accepts_def \<open>N \<subseteq> M\<close> by blast
  then obtain T where T: "T \<in> comparables S N" "T \<in> \<F>" and TSN: "T \<subseteq> S \<union> N"
    unfolding rejects_def using comparables_iff init_segment_subset by fastforce
  then consider "init_segment T S" | "init_segment S T" "S\<noteq>T" "\<not> init_segment T S"
    by (auto simp: comparables_def)
  then show False
  proof cases
    case 1
    then have "init_segment T (insert n S)" if "n \<in> N" for n
      by (meson Sup_nat_less_sets_singleton N \<open>finite S\<close> init_segment_insert that)
    with \<open>infinite N\<close> \<open>thin_set \<F>\<close> \<open>T \<in> \<F>\<close> show False
      by (meson N infinite_nat_iff_unbounded rejects_trivial)
  next
    let ?n = "Min (T-S)"
    case 2
    then have TS: "finite (T-S)" "T - S \<noteq> {}"
      using T(1) init_segment_subset by (force simp: comparables_iff)+
    then have "?n \<in> N"
      by (meson Diff_subset_conv Min_in TSN subsetD)
    then have "rejects \<F> (insert ?n S) N"
      using rejects_subset \<open>N \<subseteq> M\<close> by (auto simp: N_def)
    then have "\<not> init_segment T (insert ?n S)" "(init_segment (insert ?n S) T \<longrightarrow> insert ?n S = T)"
      using T Diff_partition TSN \<open>?n \<in> N\<close> \<open>finite S\<close>
      by (auto simp: rejects_def comparables_iff disjoint_iff)
    moreover have "S \<lless> {?n}"
      using Sup_nat_less_sets_singleton N \<open>?n \<in> N\<close> \<open>finite S\<close> by blast
    ultimately show ?thesis
      using 2 by (metis DiffD1 eq_Min_iff TS init_segment_insert_iff)
  qed
qed

text \<open>Much work is needed for this slight strengthening of the previous result!\<close>
proposition strongly_accepts_1_19_plus:
  assumes "thin_set \<F>" "infinite M"
    and dsM: "decides_subsets \<F> M"
  obtains N where "N \<subseteq> M" "infinite N"
       "\<And>S n. \<lbrakk>S \<subseteq> N; finite S; strongly_accepts \<F> S N; n \<in> N; S \<lless> {n}\<rbrakk>
              \<Longrightarrow> strongly_accepts \<F> (insert n S) N"
proof -
  define insert_closed where
    "insert_closed \<equiv> \<lambda>NL N. \<forall>T \<subseteq> Inf ` set NL. \<forall>n \<in> N.
                      strongly_accepts \<F> T ((Inf ` set NL) \<union> hd NL) \<longrightarrow>
                      T \<lless> {n} \<longrightarrow> strongly_accepts \<F> (insert n T) ((Inf ` set NL) \<union> hd NL)"
  define \<Phi> where "\<Phi> \<equiv> \<lambda>NL N. N \<subseteq> hd NL \<and> Inf N > Inf (hd NL) \<and> infinite N \<and> insert_closed NL N"
  have "\<exists>N. \<Phi> NL N" if NL: "infinite (hd NL)" "Inf ` set NL \<union> hd NL \<subseteq> M" for NL
  proof -
    let ?m = "Inf ` set NL"
    let ?M = "?m \<union> hd NL"
    define P where "P \<equiv> \<lambda>S. {n \<in> ?M. \<not> strongly_accepts \<F> (insert n S) ?M}"
    have "\<exists>k. P S \<subseteq> {..k}"
      if "S \<subseteq> Inf ` set NL" "strongly_accepts \<F> S ?M" for S
    proof -
      have "decides_subsets \<F> ?M"
        using NL(2) decides_subsets_subset dsM by blast
      with that NL assms finite_surj have "finite (P S)"
        unfolding P_def by (blast intro!: strongly_accepts_1_19)
      then show ?thesis
        by (simp add: finite_nat_iff_bounded_le)
    qed
    then obtain f where f: "\<And>S. \<lbrakk>S \<subseteq> Inf ` set NL; strongly_accepts \<F> S ?M\<rbrakk> \<Longrightarrow> P S \<subseteq> {..f S}"
      by metis
    define m where "m \<equiv> Max (insert (Inf (hd NL)) (f ` Pow (Inf ` set NL)))"
    have \<section>: "strongly_accepts \<F> (insert n S) ?M"
      if S: "S \<subseteq> Inf ` set NL" "strongly_accepts \<F> S ?M" and n: "n \<in> hd NL \<inter> {m<..}" for S n
    proof -
      have "f S \<le> m"
        unfolding m_def using that(1) by auto
      then show ?thesis
        using f [OF S] n unfolding P_def by auto
    qed
    have "\<Phi> NL (hd NL \<inter> {m<..})"
      unfolding \<Phi>_def
    proof (intro conjI)
      show "infinite (hd NL \<inter> {m<..})"
        by (simp add: finite_nat_Int_greaterThan_iff that(1))
      moreover have "Inf (hd NL) \<le> m"
        by (simp add: m_def)
      ultimately show "Inf (hd NL) < Inf (hd NL \<inter> {m<..})"
        using Inf_nat_def1 [of "(hd NL \<inter> {m<..})"] by force
      show "insert_closed NL (hd NL \<inter> {m<..})"
        by (auto intro: \<section> simp: insert_closed_def)
    qed auto
    then show ?thesis ..
  qed
  then have \<Phi>_Eps: "\<Phi> NL (Eps (\<Phi> NL))" if "infinite (hd NL)" "(Inf ` set NL) \<union> hd NL \<subseteq> M" for NL
    by (meson someI_ex that)
  define F where "F \<equiv> rec_nat [M] (\<lambda>n NL. (Eps (\<Phi> NL)) # NL)"
  have F_simps [simp]: "F 0 = [M]" "F (Suc n) = Eps (\<Phi> (F n)) # F n" for n
    by (auto simp: F_def)
  have InfM: "Inf M \<in> M"
    by (metis Inf_nat_def1 assms(2) finite.emptyI)
  have F: "F n \<noteq> [] \<and> sorted_wrt (\<le>) (F n) \<and> list.set (F n) \<subseteq> Collect infinite \<and> set (F n) \<subseteq> Pow M \<and> Inf ` set (F n) \<subseteq> M" for n
  proof (induction n)
    case (Suc n)
    have "hd (F n) \<subseteq> M"
      by (meson Pow_iff Suc.IH hd_in_set subsetD)
    then obtain \<Phi>: "Ball (list.set (F n)) ((\<subseteq>) (Eps (\<Phi> (F n))))" "infinite (Eps (\<Phi> (F n)))"
      using order_trans [OF _ sorted_wrt_subset]
      by (metis Suc.IH Un_subset_iff \<Phi>_Eps \<Phi>_def hd_in_set mem_Collect_eq subsetD)
    then have M: "Eps (\<Phi> (F n)) \<subseteq> M"
      by (meson Pow_iff Suc.IH hd_in_set subset_iff)
    with \<Phi> have "Inf (Eps (\<Phi> (F n))) \<in> M"
      by (metis Inf_nat_def1 finite.simps in_mono)
    with \<Phi> M show ?case
      using Suc by simp
  qed (auto simp: InfM \<open>infinite M\<close>)
  have \<Phi>F: "\<Phi> (F n) (Eps (\<Phi> (F n)))" for n
    by (metis Ball_Collect F Pow_iff Un_subset_iff \<Phi>_Eps hd_in_set subsetD)
  then have insert_closed: "insert_closed (F n) (Eps (\<Phi> (F n)))" for n
    using \<Phi>_def by blast
  have Eps_subset_hd: "Eps (\<Phi> (F n)) \<subseteq> hd (F n)" for n
    using \<Phi>F \<Phi>_def by blast
  define mmap where "mmap \<equiv> \<lambda>n. Inf (hd (F (Suc n)))"
  have "mmap n < mmap (Suc n)" for n
    by (metis F_simps(2) \<Phi>F \<Phi>_def list.sel(1) mmap_def)
  then have "strict_mono mmap"
    by (simp add: lift_Suc_mono_less strict_mono_def)
  then have "inj mmap"
    by (simp add: strict_mono_imp_inj_on)
  have "Eps (\<Phi> (F (Suc n))) \<subseteq> Eps (\<Phi> (F n))" for n
    by (metis F_simps(2) \<Phi>F \<Phi>_def list.sel(1))
  then have Eps_\<Phi>_decreasing: "m \<le> n \<Longrightarrow> Eps (\<Phi> (F n)) \<subseteq> Eps (\<Phi> (F m))" for m n
    by (rule order_class.lift_Suc_antimono_le)
  have hd_Suc_eq_Eps: "hd (F (Suc n)) = Eps (\<Phi> (F n))" for n
    by simp
  have "Inf (hd (F n)) \<in> hd (F n)" for n
    by (metis Inf_nat_def1 \<Phi>F \<Phi>_def finite.emptyI finite_subset)
  then have Inf_hd_in_Eps: "Inf (hd (F m)) \<in> Eps (\<Phi> (F n))" if "m>n" for m n
    by (metis Eps_\<Phi>_decreasing Nat.lessE hd_Suc_eq_Eps nat_less_le subsetD that)
  then have image_mmap_subset_hd_F: "mmap ` {n..} \<subseteq> hd (F (Suc n))" for n
    by (metis hd_Suc_eq_Eps atLeast_iff image_subsetI le_imp_less_Suc mmap_def)
  have "list.set (F k) \<subseteq> list.set (F n)" if "k \<le> n" for k n
    by (rule order_class.lift_Suc_mono_le) (use that in auto)
  then have hd_F_in_F: "hd (F k) \<in> list.set (F n)" if "k \<le> n" for k n
    by (meson F hd_in_set subsetD that)
  show ?thesis
  proof
    show infinite_mm: "infinite (range mmap)"
      using \<open>inj mmap\<close> range_inj_infinite by blast
    show "range mmap \<subseteq> M"
      using Eps_subset_hd image_mmap_subset_hd_F by fastforce
  next
    fix S a
    assume S: "S \<subseteq> range mmap" "finite S" and acc: "strongly_accepts \<F> S (range mmap)"
       and a: "a \<in> range mmap" and Sn: "S \<lless> {a}"
    then obtain n where n: "a = mmap n"
      by auto
    define N where "N \<equiv> LEAST n. S \<subseteq> mmap ` {..<n}"
    have "\<exists>n. S \<subseteq> mmap ` {..<n}"
      by (metis S finite_nat_iff_bounded finite_subset_image image_mono)
    then have S: "S \<subseteq> mmap ` {..<N}" and minS: "\<And>m. m<N \<Longrightarrow> \<not> S \<subseteq> mmap ` {..<m}"
      unfolding N_def by (meson LeastI_ex not_less_Least)+
    have range_mmap_subset: "range mmap \<subseteq> Inf ` list.set (F n) \<union> hd (F n)" for n
    proof (induction n)
      case 0
      then show ?case
        using Eps_subset_hd image_mmap_subset_hd_F by fastforce
    next
      case (Suc n)
      then show ?case
        by clarsimp (metis Inf_hd_in_Eps hd_F_in_F image_iff leI mmap_def)
    qed
    have subM: "(Inf ` list.set (F N) \<union> hd (F N)) \<subseteq> M"
      by (meson F PowD hd_in_set subsetD sup.boundedI)
    have "strongly_accepts \<F> (insert a S) (Inf ` list.set (F N) \<union> hd (F N))"
    proof (rule insert_closed [unfolded insert_closed_def, rule_format])
      have "mmap ` {..<N} \<subseteq> Inf ` list.set (F N)"
        using Suc_leI hd_F_in_F by (fastforce simp: mmap_def le_eq_less_or_eq)
      with S show Ssub: "S \<subseteq> Inf ` list.set (F N)"
        by auto
      have "S \<subseteq> mmap ` {..<n}"
        using Sn S \<open>strict_mono mmap\<close> strict_mono_less
        by (fastforce simp: less_sets_def n image_iff subset_iff Bex_def)
      with leI minS have "n\<ge>N" by blast
      then show "a \<in> Eps (\<Phi> (F N))"
        using image_mmap_subset_hd_F n by fastforce
      show "strongly_accepts \<F> S (Inf ` list.set (F N) \<union> hd (F N))"
      proof (rule ccontr)
        assume "\<not> strongly_accepts \<F> S (Inf ` list.set (F N) \<union> hd (F N))"
        then have "rejects \<F> S (Inf ` list.set (F N) \<union> hd (F N))"
          using dsM subM unfolding decides_subsets_def
          by (meson F Ssub \<open>finite S\<close> decides_def decides_subset subset_trans)
        moreover have "accepts \<F> S (range mmap)"
          using \<open>inj mmap\<close> acc range_inj_infinite strongly_accepts_imp_accepts by blast
        ultimately show False
          by (meson range_mmap_subset rejects_subset)
      qed
    qed (auto simp: Sn)
    then show "strongly_accepts \<F> (insert a S) (range mmap)"
      using range_mmap_subset strongly_accepts_subset by auto
  qed
qed

subsection \<open>Main Theorem\<close>

lemma Nash_Williams_1: "Ramsey \<F> 1"
  by (auto simp: Ramsey_eq)

theorem Nash_Williams_2:
  assumes "thin_set \<F>" shows "Ramsey \<F> 2"
  unfolding Ramsey_eq
proof clarify
  fix f :: "nat set \<Rightarrow> nat" and M :: "nat set"
  assume "infinite M" and f2: "f \<in> \<F> \<rightarrow> {..<2}"
  let ?\<F> = "\<lambda>i. f -` {i} \<inter> \<F>"  \<comment>\<open>needed with @{thm[source] Ramsey_eq}, not with  @{thm[source] Ramsey_def}\<close>
  have \<F>: "?\<F> 0 \<union> ?\<F> 1 = \<F>"
    using f2 less_2_cases by (auto simp: PiE)
  have fin\<F>: "\<And>X. X \<in> \<F> \<Longrightarrow> finite X" and thin: "\<And>i. thin_set (?\<F> i)"
    using assms thin_set_def by auto
  then obtain N where "N \<subseteq> M" "infinite N" and N: "decides_subsets (?\<F> 0) N"
    using \<open>infinite M\<close> ex_infinite_decides_subsets by blast
  then consider "rejects (?\<F> 0) {} N" | "strongly_accepts (?\<F> 0) {} N"
    unfolding decides_def decides_subsets_def by blast
  then show "\<exists>N i. N \<subseteq> M \<and> infinite N \<and> i<2 \<and> \<F> \<inter> Pow N \<subseteq> f -` {i}"
  proof cases
    case 1
    then have "(?\<F> 0 \<union> ?\<F> 1) \<inter> Pow N \<subseteq> f -` {1}"
      using f2 fin\<F> by (auto simp: Fpow_Pow_finite)
    then show ?thesis
      by (metis \<F> Suc_1 \<open>N \<subseteq> M\<close> \<open>infinite N\<close> lessI)
  next
    case 2
    then have \<section>: "\<And>P. \<lbrakk>P\<subseteq>N; \<And>S. \<lbrakk>S \<subseteq> P; finite S\<rbrakk> \<Longrightarrow> S \<notin> ?\<F> 0\<rbrakk> \<Longrightarrow> finite P"
      by (auto simp: Fpow_def disjoint_iff)
    obtain P where "P \<subseteq> N" "infinite P" and P:
      "\<And>S n. \<lbrakk>S \<subseteq> P; finite S; strongly_accepts (?\<F> 0) S P; n \<in> P; S \<lless> {n}\<rbrakk>
              \<Longrightarrow> strongly_accepts (?\<F> 0) (insert n S) P"
      using strongly_accepts_1_19_plus [OF thin \<open>infinite N\<close> N] by blast
    have "\<F> \<inter> Pow P \<subseteq> f -` {0}"
    proof (clarsimp simp: subset_vimage_iff)
      fix T
      assume T: "T \<in> \<F>" and "T \<subseteq> P"
      then have "finite T"
        using fin\<F> by blast
      moreover have "strongly_accepts (?\<F> 0) S P" if "finite S" "S \<subseteq> P" for S
        using that
      proof (induction "card S" arbitrary: S)
        case (Suc n)
        then have Seq: "S = insert (Sup S) (S - {Sup S})"
          using Sup_nat_def Max_eq_iff by fastforce
        then have sacc: "strongly_accepts (?\<F> 0) (S - {Sup S}) P"
          by (metis Suc card_Diff_singleton diff_Suc_1 finite_Diff insertCI insert_subset)
        have "S - {Sup S} \<lless> {Sup S}"
          using Suc by (simp add: Sup_nat_def dual_order.strict_iff_order less_sets_def)
        then have "strongly_accepts (?\<F> 0) (insert (Sup S) (S - {Sup S})) P"
          by (metis P Seq Suc.prems finite_Diff insert_subset sacc)
        then show ?case
          using Seq by auto
      qed (use 2 \<open>P \<subseteq> N\<close> in auto)
      ultimately have "\<exists>x\<in>comparables T P. f x = 0 \<and> x \<in> \<F>"
        using \<open>T \<subseteq> P\<close> \<open>infinite P\<close> rejects_def strongly_accepts_def by fastforce
      then show "f T = 0"
        using T assms thin_set_def comparables_def by force
    qed
    then show ?thesis
      by (meson \<open>N \<subseteq> M\<close> \<open>P \<subseteq> N\<close> \<open>infinite P\<close> less_2_cases_iff subset_trans)
  qed
qed

theorem Nash_Williams:
  assumes \<F>: "thin_set \<F>" "r > 0" shows "Ramsey \<F> r"
  using \<open>r > 0\<close>
proof (induction r)
  case (Suc r)
  show ?case
  proof (cases "r<2")
    case True
    with less_2_cases Nash_Williams_1 Nash_Williams_2 assms show ?thesis
      by (auto simp: numeral_2_eq_2)
  next
    case False
    with Suc.IH have Ram: "Ramsey \<F> r" "r \<ge> 2"
      by auto
    show ?thesis
      unfolding Ramsey_eq
    proof clarify
      fix f and M :: "nat set"
      assume fim: "f \<in> \<F> \<rightarrow> {..<Suc r}"
        and "infinite M"
      let ?within = "\<lambda>g i N. \<F> \<inter> Pow N \<subseteq> g -` {i}"
      define g where "g \<equiv> \<lambda>x. if f x = r then r-1 else f x"
      have gim: "g \<in> \<F> \<rightarrow> {..<r}"
        using fim False by (force simp: g_def)
      then obtain N i where "N \<subseteq> M" "infinite N" "i<r" and i: "?within g i N"
        using Ram \<open>infinite M\<close> by (metis Ramsey_eq)
      show "\<exists>N j. N \<subseteq> M \<and> infinite N \<and> j < Suc r \<and> ?within f j N"
      proof (cases "i<r-1")
        case True
        then have "?within f i N"
          using \<open>N \<subseteq> M\<close> \<open>infinite N\<close> \<open>i<r\<close> i by (fastforce simp add: g_def)
        then show ?thesis
          by (meson \<open>N \<subseteq> M\<close> \<open>i < r\<close> \<open>infinite N\<close> less_Suc_eq)
      next
        case False
        then have "i = r-1"
          using \<open>i<r\<close> by linarith
        then have null: "\<F> \<inter> Pow N \<subseteq> f -` {i,r}"
          using i \<open>i < r\<close>
          by (auto simp: g_def split: if_split_asm)
        define h where "h \<equiv> \<lambda>x. if f x = r then 0 else f x"
        have him: "h \<in> \<F> \<rightarrow> {..<r}"
          using fim i False \<open>i<r\<close> by (force simp: h_def)
        then obtain P j where "P \<subseteq> N" "infinite P" "j<r" and j: "?within h j P"
          using Ram \<open>i < r\<close> \<open>infinite N\<close> unfolding Ramsey_eq by metis
        have "\<exists>i < Suc r. ?within f i P"
        proof (cases "j=0")
          case True
          then have "\<F> \<inter> Pow P \<subseteq> f -` {r}"
            using Ram(2) \<open>P \<subseteq> N\<close> \<open>i = r - 1\<close>  i j
            unfolding subset_vimage_iff g_def h_def
            by (metis Int_iff Pow_iff Suc_1 diff_is_0_eq insert_iff not_less_eq_eq subset_trans)
          then show ?thesis
            by blast
        next
          case False
          then show ?thesis
            using j \<open>j < r\<close> by (fastforce simp add: h_def less_Suc_eq)
        qed
        then show ?thesis
          by (meson \<open>N \<subseteq> M\<close> \<open>P \<subseteq> N\<close> \<open>infinite P\<close> subset_trans)
      qed
    qed
  qed
qed auto

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Indices of Sets} *}
theory SetIndex
imports
  "../spec/MapSpec"
  "../spec/SetSpec"
begin
text_raw {*\label{thy:SetIndex}*}

text {*
  This theory defines an indexing operation that builds an index from a set
  and an indexing function.

  Here, index is a map from indices to all values of the set with that index.
  *}

subsection "Indexing by Function"

definition index :: "('a \<Rightarrow> 'i) \<Rightarrow> 'a set \<Rightarrow> 'i \<Rightarrow> 'a set"
  where "index f s i == { x\<in>s . f x = i }"

lemma indexI: "\<lbrakk> x\<in>s; f x = i \<rbrakk> \<Longrightarrow> x\<in>index f s i" by (unfold index_def) auto
lemma indexD:
  "x\<in>index f s i \<Longrightarrow> x\<in>s"
  "x\<in>index f s i \<Longrightarrow> f x = i"
  by (unfold index_def) auto

lemma index_iff[simp]: "x\<in>index f s i \<longleftrightarrow> x\<in>s \<and> f x = i" by (simp add: index_def)

subsection "Indexing by Map"

definition index_map :: "('a \<Rightarrow> 'i) \<Rightarrow> 'a set \<Rightarrow> 'i \<rightharpoonup> 'a set"
  where "index_map f s i == let s=index f s i in if s={} then None else Some s"

definition im_\<alpha> where "im_\<alpha> im i == case im i of None \<Rightarrow> {} | Some s \<Rightarrow> s"

lemma index_map_correct: "im_\<alpha> (index_map f s) = index f s"
  apply (rule ext)
  apply (unfold index_def index_map_def im_\<alpha>_def)
  apply auto
  done

subsection "Indexing by Maps and Sets from the Isabelle Collections Framework"
text {*
  In this theory, we define the generic algorithm as constants outside any locale,
  but prove the correctness lemmas inside a locale that assumes correctness of all
  prerequisite functions.
  Finally, we export the correctness lemmas from the locale.
*}

locale index_loc =
  m!: StdMap m_ops +
  s!: StdSet s_ops
  for m_ops :: "('i,'s,'m,'more1) map_ops_scheme"
  and s_ops :: "('x,'s,'more2) set_ops_scheme"
begin
  -- "Mapping indices to abstract indices"
  definition ci_\<alpha>' where
    "ci_\<alpha>' ci i == case m.\<alpha> ci i of None \<Rightarrow> None | Some s \<Rightarrow> Some (s.\<alpha> s)"

  definition "ci_\<alpha> == im_\<alpha> \<circ> ci_\<alpha>'"

  definition ci_invar where
    "ci_invar ci == m.invar ci \<and> (\<forall>i s. m.\<alpha> ci i = Some s \<longrightarrow> s.invar s)"

  lemma ci_impl_minvar: "ci_invar m \<Longrightarrow> m.invar m" by (unfold ci_invar_def) auto

  definition is_index :: "('x \<Rightarrow> 'i) \<Rightarrow> 'x set \<Rightarrow> 'm \<Rightarrow> bool"
  where
    "is_index f s idx == ci_invar idx \<and> ci_\<alpha>' idx = index_map f s"

  lemma is_index_invar: "is_index f s idx \<Longrightarrow> ci_invar idx"
    by (simp add: is_index_def)

  lemma is_index_correct: "is_index f s idx \<Longrightarrow> ci_\<alpha> idx = index f s"
    by (unfold is_index_def index_map_def ci_\<alpha>_def)
       (simp add: index_map_correct)

  definition lookup :: "'i \<Rightarrow> 'm \<Rightarrow> 's" where
    "lookup i m == case m.lookup i m of None \<Rightarrow> (s.empty ()) | Some s \<Rightarrow> s"

  lemma lookup_invar': "ci_invar m \<Longrightarrow> s.invar (lookup i m)"
    apply (unfold ci_invar_def lookup_def)
    apply (auto split: option.split simp add: m.lookup_correct s.empty_correct)
    done

  lemma lookup_correct:
    assumes I[simp, intro!]: "is_index f s idx"
    shows
      "s.\<alpha> (lookup i idx) = index f s i"
      "s.invar (lookup i idx)"
  proof -
    case goal2 thus ?case using I by (simp add: is_index_def lookup_invar')
  next
    case goal1
    have [simp, intro!]: "m.invar idx"
      using ci_impl_minvar[OF is_index_invar[OF I]]
      by simp
    thus ?case
    proof (cases "m.lookup i idx")
      case None
      hence [simp]: "m.\<alpha> idx i = None" by (simp add: m.lookup_correct)
      from is_index_correct[OF I] have "index f s i = ci_\<alpha> idx i" by simp
      also have "\<dots> = {}" by (simp add: ci_\<alpha>_def ci_\<alpha>'_def im_\<alpha>_def)
      finally show ?thesis by (simp add: lookup_def None s.empty_correct)
    next
      case (Some si)
      hence [simp]: "m.\<alpha> idx i = Some si" by (simp add: m.lookup_correct)
      from is_index_correct[OF I] have "index f s i = ci_\<alpha> idx i" by simp
      also have "\<dots> = s.\<alpha> si" by (simp add: ci_\<alpha>_def ci_\<alpha>'_def im_\<alpha>_def)
      finally show ?thesis by (simp add: lookup_def Some s.empty_correct)
    qed
  qed

end

locale build_index_loc = index_loc m_ops s_ops +
  t!: StdSet t_ops
  for m_ops :: "('i,'s,'m,'more1) map_ops_scheme"
  and s_ops :: "('x,'s,'more3) set_ops_scheme"
  and t_ops :: "('x,'t,'more2) set_ops_scheme"
begin

  text "Building indices"
  definition idx_build_stepfun :: "('x \<Rightarrow> 'i) \<Rightarrow> 'x \<Rightarrow> 'm \<Rightarrow> 'm" where
    "idx_build_stepfun f x m ==
      let i=f x in
        (case m.lookup i m of
          None \<Rightarrow> m.update i (s.ins x (s.empty ())) m |
          Some s \<Rightarrow> m.update i (s.ins x s) m
      )"

  definition idx_build :: "('x \<Rightarrow> 'i) \<Rightarrow> 't \<Rightarrow> 'm" where
    "idx_build f t == t.iterate t (idx_build_stepfun f) (m.empty ())"

  lemma idx_build_correct:
    assumes I: "t.invar t"
    shows "ci_\<alpha>' (idx_build f t) = index_map f (t.\<alpha> t)" (is ?T1) and
    [simp]: "ci_invar (idx_build f t)" (is ?T2)
  proof -
    have "t.invar t \<Longrightarrow>
      ci_\<alpha>' (idx_build f t) = index_map f (t.\<alpha> t) \<and> ci_invar (idx_build f t)"
      apply (unfold idx_build_def)
      apply (rule_tac
          I="\<lambda>it m. ci_\<alpha>' m = index_map f (t.\<alpha> t - it) \<and> ci_invar m"
          in t.iterate_rule_P)
      apply assumption
      apply (simp add: ci_invar_def m.empty_correct)
      apply (rule ext)
      apply (unfold ci_\<alpha>'_def index_map_def index_def)[1]
      apply (simp add: m.empty_correct)
      defer
      apply simp
      apply (rule conjI)
      defer
      apply (unfold idx_build_stepfun_def)[1]
      apply (auto
        simp add: ci_invar_def m.update_correct m.lookup_correct
                  s.empty_correct s.ins_correct Let_def
        split: option.split) [1]

      apply (rule ext)
    proof -
      case (goal1 x it m i)
      hence INV[simp, intro!]: "m.invar m" by (simp add: ci_invar_def)
      from goal1 have
        INVS[simp, intro]: "!!q s. m.\<alpha> m q = Some s \<Longrightarrow> s.invar s"
        by (simp add: ci_invar_def)

      show ?case proof (cases "i=f x")
        case True[simp]
        show ?thesis proof (cases "m.\<alpha> m (f x)")
          case None[simp]
          hence "idx_build_stepfun f x m = m.update i (s.ins x (s.empty ())) m"
            apply (unfold idx_build_stepfun_def)
            apply (simp add: m.update_correct m.lookup_correct s.empty_correct)
            done
          hence "ci_\<alpha>' (idx_build_stepfun f x m) i = Some {x}"
            by (simp add: m.update_correct
                          s.ins_correct s.empty_correct ci_\<alpha>'_def)
          also {
            have "None = ci_\<alpha>' m (f x)"
              by (simp add: ci_\<alpha>'_def)
            also from goal1(4) have "\<dots> = index_map f (t.\<alpha> t - it) i" by simp
            finally have E: "{xa \<in> t.\<alpha> t - it. f xa = i} = {}"
              by (simp add: index_map_def index_def split: split_if_asm)
            moreover have
              "{xa \<in> t.\<alpha> t - (it - {x}). f xa = i}
               = {xa \<in> t.\<alpha> t - it. f xa = i} \<union> {x}"
              using goal1(2,3) by auto
            ultimately have "Some {x} = index_map f (t.\<alpha> t - (it - {x})) i"
              by (unfold index_map_def index_def) auto
          } finally show ?thesis .
        next
          case (Some ss)[simp]
          hence [simp, intro!]: "s.invar ss" by (simp del: Some)
          hence "idx_build_stepfun f x m = m.update (f x) (s.ins x ss) m"
            by (unfold idx_build_stepfun_def)
               (simp add: m.update_correct m.lookup_correct)
          hence "ci_\<alpha>' (idx_build_stepfun f x m) i = Some (insert x (s.\<alpha> ss))"
            by (simp add: m.update_correct s.ins_correct ci_\<alpha>'_def)
          also {
              have "Some (s.\<alpha> ss) = ci_\<alpha>' m (f x)"
                by (simp add: ci_\<alpha>'_def)
            also from goal1(4) have "\<dots> = index_map f (t.\<alpha> t - it) i" by simp
            finally have E: "{xa \<in> t.\<alpha> t - it. f xa = i} = s.\<alpha> ss"
              by (simp add: index_map_def index_def split: split_if_asm)
            moreover have
              "{xa \<in> t.\<alpha> t - (it - {x}). f xa = i}
               = {xa \<in> t.\<alpha> t - it. f xa = i} \<union> {x}"
              using goal1(2,3) by auto
            ultimately have
              "Some (insert x (s.\<alpha> ss)) = index_map f (t.\<alpha> t - (it - {x})) i"
              by (unfold index_map_def index_def) auto
          }
          finally show ?thesis .
        qed
      next
        case False hence C: "i\<noteq>f x" "f x\<noteq>i" by simp_all
        have "ci_\<alpha>' (idx_build_stepfun f x m) i = ci_\<alpha>' m i"
          apply (unfold ci_\<alpha>'_def idx_build_stepfun_def)
          apply (simp
            split: option.split_asm option.split
            add: Let_def m.lookup_correct m.update_correct
                 s.ins_correct s.empty_correct C)
          done
        also from goal1(4) have "ci_\<alpha>' m i = index_map f (t.\<alpha> t - it) i"
          by simp
        also have
          "{xa \<in> t.\<alpha> t - (it - {x}). f xa = i} = {xa \<in> t.\<alpha> t - it. f xa = i}"
          using goal1(2,3) C by auto
        hence "index_map f (t.\<alpha> t - it) i = index_map f (t.\<alpha> t - (it-{x})) i"
          by (unfold index_map_def index_def) simp
        finally show ?thesis .
      qed
    qed
    with I show ?T1 ?T2 by auto
  qed

  lemma idx_build_is_index:
    "t.invar t \<Longrightarrow> is_index f (t.\<alpha> t) (idx_build f t)"
    by (simp add: idx_build_correct index_map_correct ci_\<alpha>_def is_index_def)

end

end


theory Submission
  imports Defs
begin

lemma good_only_if: "good_node i \<Longrightarrow> E\<^sup>*\<^sup>* i 0"
  by (induction i rule: good_node.induct) auto

lemma good_if: "E\<^sup>*\<^sup>* i j \<Longrightarrow> good_node j \<Longrightarrow> good_node i"
  by (induction i j rule: rtranclp.induct) (auto intro: good_node.intros)

theorem good_node_def:
  "good_node i \<longleftrightarrow> E\<^sup>*\<^sup>* i 0"
  using good_only_if good_if[OF _ good_node.intros(1)]
  by auto

lemma good_node_1:
  assumes "good_node i" "i < n" "i > 0" "E\<^sup>*\<^sup>* i j" "E\<^sup>+\<^sup>+ j j"
  shows False
  using assms
proof (induction i rule: good_node.induct)
  case (2 k i)
  have good_i: "good_node i"
    using 2(1,2)
    by (auto intro: good_node.intros)
  have k_0: "0 < k"
    using 2(2,6,7)
    by (metis E_def converse_rtranclpE tranclpD)
  have k_n: "k < n"
    using 2(2)
    by (auto simp: E_def)
  have E_k_j: "E\<^sup>*\<^sup>* k j"
    using 2(2,6)
    by (metis E_def assms(5) rtranclp_tranclp_tranclp tranclpD)
  show ?case
    by (rule 2(3)[OF k_n k_0 E_k_j 2(7)])
qed auto

theorem good_node_characterization_1:
  assumes "i < n" "i > 0" "good_node i"
  shows "\<not> (\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)"
  using good_node_1 assms
  by auto

lemma term_aux:
  assumes "i < n" "i \<notin> set ns"
  shows "card (set ns \<inter> {..<n}) < n"
  using assms
  by (metis card_lessThan card_seteq finite_lessThan inf_commute inf_le1 lessThan_iff
      not_le subsetD)

function sucs :: "nat \<Rightarrow> nat list \<Rightarrow> nat list" where
  "sucs i ns = (if i < n then (if i \<in> set ns \<or> i = 0 then [i] else
    i # sucs (graph ! i) (ns @ [i])) else [])"
  by pat_completeness auto
termination
  using term_aux diff_less_mono2
  by (relation "measure (\<lambda>(i, ns). n - (card (set ns \<inter> {..<n})))") auto

lemma sucs_sound:
  assumes "i < n" "set ns \<subseteq> {..<n}" "\<And>k. k \<in> set ns \<Longrightarrow> E\<^sup>+\<^sup>+ k i" "j = last (sucs i ns)"
  shows "E\<^sup>*\<^sup>* i j \<and> (j = 0 \<or> E\<^sup>+\<^sup>+ j j)"
  using assms
proof (induction i ns rule: sucs.induct)
  case (1 i ns)
  show ?case
    using 1(2,4,5)
  proof (cases "i \<in> set ns \<or> i = 0")
    case False
    have wf: "graph ! i < n"
      using 1(2) wellformed
      by (auto simp: n_def)
    have set: "set (ns @ [i]) \<subseteq> {..<n}"
      using 1(2,3)
      by auto
    have hd: "hd (sucs i ns) = i" "hd (sucs (graph ! i) (ns @ [i])) = graph ! i"
      using 1(2) wf
      by auto
    have "E i (graph ! i)"
      using 1(2) wf False
      by (auto simp: E_def)
    then have prem: "\<And>k. k \<in> set (ns @ [i]) \<Longrightarrow> E\<^sup>+\<^sup>+ k (graph ! i)"
      using 1(4)
      by force
    have E_star: "E\<^sup>*\<^sup>* (graph ! i) j \<and> (j = 0 \<or> E\<^sup>+\<^sup>+ j j)"
      using 1(1)[OF 1(2) False wf set prem] 1(2,5) False wf
      by (metis last_ConsR list.distinct(1) sucs.elims)
    moreover have "E i (graph ! i)"
      using 1(2) wf False
      by (auto simp: E_def)
    ultimately show ?thesis
      unfolding hd(2)
      by auto
  qed auto
qed

theorem good_node_characterization_2:
  assumes "i < n" "i > 0" "\<not> (\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)"
  shows "good_node i"
proof -
  define j where "j = last (sucs i [])"
  have "E\<^sup>*\<^sup>* i j" "j = 0 \<or> E\<^sup>+\<^sup>+ j j"
    using sucs_sound[OF assms(1), of "[]", folded j_def] assms(1,2)
    by auto
  then show ?thesis
    using assms(2,3)
    unfolding good_node_def
    by auto
qed

corollary good_node_characterization:
  assumes "i < n" "i > 0"
  shows "good_node i \<longleftrightarrow> \<not> (\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)"
  using good_node_characterization_1 good_node_characterization_2 assms by blast

end


theory Examples_3 = Main:
typedecl "Elem"
typedecl "Stream"
consts
"cons" :: "Elem => Stream => Stream"
"even" :: "Stream => Stream"
"hd" :: "Stream => Elem"
"merge" :: "Stream => Stream => Stream"
"odd" :: "Stream => Stream"
"tl" :: "Stream => Stream"

axioms
X: "!! s :: Stream . (hd (odd s)) = (hd s)"
X1: "!! s :: Stream . (tl (odd s)) = (odd (tl (tl s)))"
X2: "!! s :: Stream . (hd (even s)) = (hd (tl s))"
X3: "!! s :: Stream . (tl (even s)) = (even (tl (tl s)))"
X4: "!! s1 :: Stream . !! s2 :: Stream . (hd (merge s1 s2)) = (hd s1)"
X5: "!! s1 :: Stream . !! s2 :: Stream . (tl (merge s1 s2)) = merge s2 (tl s1)"
ga_cogenerated_Stream: "!! R :: Stream => Stream => bool . !! u :: Stream . !! v :: Stream . ! x :: Stream . ! y :: Stream . ((R x) y) --> (hd x) = (hd y) & ((R (tl x)) (tl y)) ==> ((R u) v) ==> u = v"
ga_selector_hd: "!! X1 :: Elem . !! X2 :: Stream . (hd (cons X1 X2)) = X1"
ga_selector_tl: "!! X1 :: Elem . !! X2 :: Stream . (tl (cons X1 X2)) = X2"

lemmas Xa = X [simplified]
declare Xa[simp]
declare X[simp]
lemmas X1a = X1 [simplified]
declare X1a[simp]
declare X1[simp]
lemmas X2a = X2 [simplified]
declare X2a[simp]
declare X2[simp]
lemmas X3a = X3 [simplified]
declare X3a[simp]
declare X3[simp]
lemmas X4a = X4 [simplified]
declare X4a[simp]
declare X4[simp]
lemmas X5a = X5 [simplified]
declare X5a[simp]
declare X5[simp]
lemmas ga_cogenerated_Streama = ga_cogenerated_Stream [simplified]
declare ga_cogenerated_Streama[simp]
declare ga_cogenerated_Stream[simp]
lemmas ga_selector_hda = ga_selector_hd [simplified]
declare ga_selector_hda[simp]
declare ga_selector_hd[simp]
lemmas ga_selector_tla = ga_selector_tl [simplified]
declare ga_selector_tla[simp]
declare ga_selector_tl[simp]

theorem X6: "!! s :: Stream . merge (odd s) (even s) = s"
apply(rule_tac R="% x y . (? t . (x=merge (odd t) (even t) & y=t)) | BinRelImage tl ?R1 x y" in ga_cogenerated_Stream)
defer
ML "set show_types"
apply(simp)
apply(rule allI)
apply(rule allI)
apply(rule impI)
apply(erule disjE)
apply(erule exE)
apply(rule conjI)
apply(simp add: X X1 X2 X3 X4 X5 )
apply(rule disjI2)
apply(tactic "instantiate_tac [(\"R1\" , \" % s x y.(? t.(x=merge (odd t) (even t) & y=t))\" )]")
apply(simp add: BinRelImage_def)
apply(rule_tac x=t in exI)
apply(simp)
apply(rule conjI)
apply(simp add: BinRelImage_def)
apply(erule exE)
ML "set trace_simp"
apply(simp add: X X1 X2 X3 X4 X5)
apply(erule conjE)
apply(drule sym)
apply(drule sym)
apply(simp add: X X1 X2 X3 X4 X5)
apply(simp add: BinRelImage_def)
apply(erule exE)
apply(erule conjE)
apply(drule sym)
apply(drule sym)
apply(simp add: X X1 X2 X3 X4 X5)
done

end