(*  Title:      Group Actions
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer at student.kit.edu>
*)

theory GroupAction
imports
  "HOL-Algebra.Bij"
  "HOL-Algebra.Sylow"
begin

section \<open>Group Actions\<close>

text \<open>This is an implemention of group actions based on the group
implementation of HOL-Algebra. An action a group $G$ on a set $M$ is
represented by a group homomorphism between $G$ and the group of bijections
on $M$\<close>

subsection \<open>Preliminaries and Definition\<close>

text \<open>First, we need two theorems about singletons and sets of singletons
which unfortunately are not included in the library.\<close>

theorem singleton_intersection:
  assumes A:"card A = 1"
  assumes B:"card B = 1"
  assumes noteq:"A \<noteq> B"
  shows "A \<inter> B = {}"
using assms by(auto simp:card_Suc_eq)

theorem card_singleton_set:
  assumes cardOne:"\<forall>x \<in> A.(card x = 1)"
  shows "card (\<Union>A) = card A"
proof -
  have "card (\<Union>A) = (\<Sum>x\<in>A. card x)"
  proof(rule card_Union_disjoint)
    from cardOne show "\<And>a. a\<in>A \<Longrightarrow> finite a" by (auto intro: card_ge_0_finite)
  next
    show "pairwise disjnt A"
      unfolding pairwise_def disjnt_def
    proof(clarify)
      fix x y
      assume x:"x \<in> A" and y:"y \<in> A" and "x \<noteq> y"
      with cardOne have "card x = 1" "card y = 1" by auto
      with \<open>x \<noteq> y\<close> show "x \<inter> y = {}" by (metis singleton_intersection)
    qed
  qed
  also from cardOne have "... = card A" by simp
  finally show ?thesis.
qed

text \<open>Intersecting Cosets are equal:\<close>

lemma (in subgroup) repr_independence2:
  assumes group:"group G"
  assumes U:"U \<in> rcosets\<^bsub>G\<^esub> H"
  assumes g:"g \<in> U"
  shows "U = H #> g"
proof -
  from U obtain h where h:"h \<in> carrier G" "U = H #> h" unfolding RCOSETS_def by auto
  with g have "g \<in> H #> h" by simp
  with group h show "U = H #> g" by (metis group.repr_independence is_subgroup)
qed

locale group_action = group +
  fixes \<phi> M
  assumes grouphom:"group_hom G (BijGroup M) \<phi>"

context group_action
begin

lemma is_group_action:"group_action G \<phi> M"..

text \<open>The action of @{term "\<one>\<^bsub>G\<^esub>"} has no effect:\<close>

lemma one_is_id:
  assumes "m \<in> M"
  shows "(\<phi> \<one>) m = m"
proof -
  from grouphom have "(\<phi> \<one>) m = \<one>\<^bsub>(BijGroup M)\<^esub> m" by (metis group_hom.hom_one)
  also have "... = (\<lambda>x\<in>M. x) m" unfolding BijGroup_def by (metis monoid.select_convs(2))
  also from assms have "... = m" by simp
  finally show ?thesis.
qed

lemma action_closed:
  assumes m:"m \<in> M"
  assumes g:"g \<in> carrier G"
  shows "\<phi> g m \<in> M"
using assms grouphom group_hom.hom_closed unfolding BijGroup_def Bij_def bij_betw_def by fastforce

lemma img_in_bij:
  assumes "g \<in> carrier G"
  shows "(\<phi> g) \<in> Bij M"
using assms grouphom unfolding BijGroup_def by (auto dest: group_hom.hom_closed)

text \<open>The action of @{term "inv g"} reverts the action of @{term g}\<close>

lemma group_inv_rel:
  assumes g:"g \<in> carrier G"
  assumes mn:"m \<in> M" "n \<in> M"
  assumes phi:"(\<phi> g) n = m"
  shows "(\<phi> (inv g)) m = n"
proof -
  from g have bij:"(\<phi> g) \<in> Bij M" unfolding BijGroup_def by (metis img_in_bij)
  with g grouphom have "\<phi> (inv g) = restrict (inv_into M (\<phi> g)) M" by(metis inv_BijGroup group_hom.hom_inv)
  hence "\<phi> (inv g) m = (restrict (inv_into M (\<phi> g)) M) m" by simp
  also from mn have "... = (inv_into M (\<phi> g)) m" by (metis restrict_def)
  also from g phi have "... = (inv_into M (\<phi> g)) ((\<phi> g) n)" by simp
  also from \<open>\<phi> g \<in> Bij M\<close> Bij_def have "bij_betw (\<phi> g) M M" by auto
  hence "inj_on (\<phi> g) M" by (metis bij_betw_imp_inj_on)
  with g mn have "(inv_into M (\<phi> g)) ((\<phi> g) n) = n" by (metis inv_into_f_f)
  finally show "\<phi> (inv g) m = n".
qed

lemma images_are_bij:
  assumes g:"g \<in> carrier G"
  shows "bij_betw (\<phi> g) M M"
proof -
  from g have bij:"(\<phi> g) \<in> Bij M" unfolding BijGroup_def by (metis img_in_bij)
  with Bij_def show "bij_betw (\<phi> g) M M" by auto
qed

lemma action_mult:
  assumes g:"g \<in> carrier G"
  assumes h:"h \<in> carrier G"
  assumes m:"m \<in> M"
  shows "(\<phi> g) ((\<phi> h) m) = (\<phi> (g \<otimes> h)) m"
proof -
  from g have \<phi>g:"(\<phi> g) \<in> Bij M" unfolding BijGroup_def by (rule img_in_bij)
  from h have \<phi>h:"(\<phi> h) \<in> Bij M" unfolding BijGroup_def by (rule img_in_bij)
  from h have "bij_betw (\<phi> h) M M" by (rule images_are_bij)
  hence "(\<phi> h) ` M = M" by (metis bij_betw_def)
  with m have hm:"(\<phi> h) m \<in> M" by (metis imageI)
  from grouphom g h have "(\<phi> (g \<otimes> h)) = ((\<phi> g) \<otimes>\<^bsub>(BijGroup M)\<^esub> (\<phi> h))" by (rule group_hom.hom_mult)
  hence "\<phi> (g \<otimes> h) m = ((\<phi> g) \<otimes>\<^bsub>(BijGroup M)\<^esub> (\<phi> h)) m" by simp
  also from \<phi>g \<phi>h have "... = (compose M (\<phi> g) (\<phi> h)) m" unfolding BijGroup_def by simp
  also from \<phi>g \<phi>h hm have "... = (\<phi> g) ((\<phi> h) m)" by (metis compose_eq m)
  finally show "(\<phi> g) ((\<phi> h) m) = (\<phi> (g \<otimes> h)) m"..
qed

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

text \<open>The following describes the relation containing the information
whether two elements of @{term M} lie in the same orbit of the action\<close>

definition same_orbit_rel
  where "same_orbit_rel = {p \<in> M \<times> M. \<exists>g \<in> carrier G. (\<phi> g) (snd p) = (fst p)}"

text \<open>Use the library about equivalence relations to define the set of
orbits and the map assigning to each element of @{term M} its orbit\<close>

definition orbits
 where "orbits = M // same_orbit_rel"

definition orbit :: "'c \<Rightarrow> 'c set"
  where "orbit m = same_orbit_rel `` {m}"

text \<open>Next, we define a more easy-to-use characterization of an orbit.\<close>

lemma orbit_char:
  assumes m:"m \<in> M"
  shows "orbit m = {n. \<exists>g. g \<in> carrier G \<and> (\<phi> g) m = n}"
using assms unfolding orbit_def Image_def same_orbit_rel_def
proof(auto)
  fix x g
  assume g:"g \<in> carrier G" and "\<phi> g x \<in> M" "x \<in> M"
  hence "\<phi> (inv g) (\<phi> g x) = x" by (metis group_inv_rel)
  moreover from g have "inv g \<in> carrier G" by (rule inv_closed)
  ultimately show "\<exists>h. h \<in> carrier G \<and> \<phi> h (\<phi> g x) = x" by auto
next
  fix g
  assume g:"g \<in> carrier G"
  with m show "\<phi> g m \<in> M" by (metis action_closed)
  with m g have "\<phi> (inv g) (\<phi> g m) = m" by (metis group_inv_rel)
  moreover from g have "inv g \<in> carrier G" by (rule inv_closed)
  ultimately show "\<exists>h\<in>carrier G. \<phi> h (\<phi> g m) = m" by auto
qed

text \<open>Now we show that the relation we've defined is, indeed, an
equivalence relation:\<close>

lemma same_orbit_is_equiv:
  shows "equiv M same_orbit_rel"
proof(rule equivI)
  show "refl_on M same_orbit_rel"
  proof(rule refl_onI)
    show "same_orbit_rel \<subseteq> M \<times> M" unfolding same_orbit_rel_def by auto
  next
    fix m
    assume "m \<in> M"
    hence "(\<phi> \<one>) m = m" by(rule one_is_id)
    with \<open>m \<in> M\<close> show  "(m, m) \<in> same_orbit_rel" unfolding same_orbit_rel_def by (auto simp:same_orbit_char)
  qed
next
  show "sym same_orbit_rel"
  proof(rule symI)
    fix m n
    assume mn:"(m, n) \<in> same_orbit_rel"
    then obtain g where g:"g \<in> carrier G" "\<phi> g n = m" unfolding same_orbit_rel_def by auto
    hence invg:"inv g \<in> carrier G" by (metis inv_closed)
    from mn have "(m, n) \<in> M \<times> M" unfolding same_orbit_rel_def by simp
    hence mn2:"m \<in> M" "n \<in> M" by auto
    from g mn2 have "\<phi> (inv g) m = n" by (metis group_inv_rel)
    with invg mn2 show "(n, m) \<in> same_orbit_rel" unfolding same_orbit_rel_def by auto
  qed
next
  show "trans same_orbit_rel"
  proof(rule transI)
    fix x y z
    assume xy:"(x, y) \<in> same_orbit_rel"
    then obtain g where g:"g \<in> carrier G" and grel:"(\<phi> g) y = x" unfolding same_orbit_rel_def by auto
    assume yz:"(y, z) \<in> same_orbit_rel"
    then obtain h where h:"h \<in> carrier G" and hrel:"(\<phi> h) z = y" unfolding same_orbit_rel_def by auto
    from g h have gh:"g \<otimes> h \<in> carrier G" by simp
    from xy yz have "x \<in> M" "z \<in> M" unfolding same_orbit_rel_def by auto
    with g h have "\<phi> (g \<otimes> h) z = (\<phi> g) ((\<phi> h) z)" by (metis action_mult)
    also from hrel grel have "... = x" by simp
    finally have "\<phi> (g \<otimes> h) z = x".
    with gh \<open>x \<in> M\<close> \<open>z \<in> M\<close> show "(x, z) \<in> same_orbit_rel" unfolding same_orbit_rel_def by auto
  qed
qed

subsection \<open>Stabilizer and fixed points\<close>

text \<open>The following definition models the stabilizer of a group action:\<close>

definition stabilizer :: "'c \<Rightarrow> _"
  where "stabilizer m = {g \<in> carrier G. (\<phi> g) m = m}"

text \<open>This shows that the stabilizer of @{term m} is a subgroup of @{term G}.\<close>

lemma stabilizer_is_subgroup:
  assumes m:"m \<in> M"
  shows "subgroup (stabilizer m) G"
proof(rule subgroupI)
  show "stabilizer m \<subseteq> carrier G" unfolding stabilizer_def by auto
next
  from m have "(\<phi> \<one>) m = m" by (rule one_is_id)
  hence "\<one> \<in> stabilizer m" unfolding stabilizer_def by simp
  thus "stabilizer m \<noteq> {}" by auto
next
  fix g
  assume g:"g \<in> stabilizer m"
  hence "g \<in> carrier G" "(\<phi> g) m = m" unfolding stabilizer_def by simp+
  with m have ginv:"(\<phi> (inv g)) m = m" by (metis group_inv_rel)
  from \<open>g \<in> carrier G\<close> have "inv g \<in> carrier G" by (metis inv_closed)
  with ginv show "(inv g) \<in>  stabilizer m" unfolding stabilizer_def by simp
next
  fix g h
  assume g:"g \<in> stabilizer m"
  hence g2:"g \<in> carrier G" unfolding stabilizer_def by simp
  assume h:"h \<in> stabilizer m"
  hence h2:"h \<in> carrier G" unfolding stabilizer_def by simp
  with g2 have gh:"g \<otimes> h \<in> carrier G" by (rule m_closed)
  from g2 h2 m have "\<phi> (g \<otimes> h) m = (\<phi> g) ((\<phi> h) m)" by (metis action_mult)
  also from g h have "... = m" unfolding stabilizer_def by simp
  finally have "\<phi> (g \<otimes> h) m = m".
  with gh show "g \<otimes> h \<in> stabilizer m" unfolding stabilizer_def by simp
qed

text \<open>Next, we define and characterize the fixed points of a group action.\<close>

definition fixed_points :: "'c set"
  where "fixed_points = {m \<in> M. carrier G \<subseteq> stabilizer m}"

lemma fixed_point_char:
  assumes "m \<in> M"
  shows "(m \<in> fixed_points) = (\<forall>g\<in>carrier G. \<phi> g m = m)"
using assms unfolding fixed_points_def stabilizer_def by force

lemma orbit_contains_rep:
  assumes m:"m \<in> M"
  shows "m \<in> orbit m"
unfolding orbit_def using assms by (metis equiv_class_self same_orbit_is_equiv)

lemma singleton_orbit_eq_fixed_point:
  assumes m:"m \<in> M"
  shows "(card (orbit m) = 1) = (m \<in> fixed_points)"
proof
  assume card:"card (orbit m) = 1"
  from m have "m \<in> orbit m" by (rule orbit_contains_rep)
  from m show "m \<in> fixed_points" unfolding fixed_points_def
  proof(auto)
    fix g
    assume gG:"g \<in> carrier G"
    with m have "\<phi> g m \<in> orbit m" by (auto dest:orbit_char)
    with \<open>m \<in> orbit m\<close> card have "\<phi> g m = m" by (auto simp add: card_Suc_eq)
    with gG show "g \<in> stabilizer m" unfolding stabilizer_def by simp
  qed
next
  assume "m \<in> fixed_points"
  hence fixed:"carrier G \<subseteq> stabilizer m" unfolding fixed_points_def by simp
  from m have "orbit m = {m}"
  proof(auto simp add: orbit_contains_rep)
    fix n
    assume "n \<in> orbit m"
    with m obtain g where g:"g \<in> carrier G" "\<phi> g m = n"  by (auto dest: orbit_char)
    moreover with fixed have "\<phi> g m = m" unfolding stabilizer_def by auto
    ultimately show "n = m" by simp
  qed
  thus "card (orbit m) = 1" by simp
qed

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

text \<open>This section contains some theorems about orbits and their quotient
groups. The first one is the well-known orbit-stabilizer theorem which
establishes a bijection between the the quotient group of the an element's
stabilizer and its orbit.\<close>

theorem orbit_thm:
  assumes m:"m \<in> M"
  assumes rep:"\<And>U. U \<in> (carrier (G Mod (stabilizer m))) \<Longrightarrow> rep U \<in> U"
  shows "bij_betw (\<lambda>H. (\<phi> (inv (rep H)) m)) (carrier (G Mod (stabilizer m))) (orbit m)"
proof(auto simp add:bij_betw_def)
  show "inj_on (\<lambda>H. \<phi> (inv (rep H)) m) (carrier (G Mod stabilizer m))"
  proof(rule inj_onI)
    fix U V
    assume U:"U \<in> carrier (G Mod (stabilizer m))"
    assume V:"V \<in> carrier (G Mod (stabilizer m))"
    define h where "h = rep V"
    define g where "g = rep U"
    have stabSubset:"(stabilizer m) \<subseteq> carrier G" unfolding stabilizer_def by auto
    from m have stabSubgroup: "subgroup (stabilizer m) G" by (metis stabilizer_is_subgroup)
    from V rep have hV:"h \<in> V" unfolding h_def by simp
    from V stabSubset have "V \<subseteq> carrier G" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
    with hV have hG:"h \<in> carrier G" by auto
    hence hinvG:"inv h \<in> carrier G" by (metis inv_closed)
    from U rep have gU:"g \<in> U" unfolding g_def by simp
    from U stabSubset have "U \<subseteq> carrier G" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
    with gU have gG:"g \<in> carrier G" by auto
    hence ginvG:"inv g \<in> carrier G" by (metis inv_closed)
    from gG hinvG have ginvhG: "g \<otimes> inv h \<in> carrier G" by (metis m_closed)
    assume reps:"\<phi> (inv rep U) m = \<phi> (inv rep V) m"
    hence gh:"\<phi> (inv g) m = \<phi> (inv h) m" unfolding g_def h_def.
    from gG hinvG m have "\<phi> (g \<otimes> (inv h)) m = \<phi> g (\<phi> (inv h) m)" by (metis action_mult)
    also from gh ginvG gG m have "... = \<phi> (g \<otimes> inv g) m" by (metis action_mult)
    also from m gG have "... = m" by (auto simp: one_is_id)
    finally have "\<phi> (g \<otimes> inv h) m = m".
    with ginvhG have "(g \<otimes> inv h) \<in> stabilizer m"
      unfolding stabilizer_def by simp
    hence "(stabilizer m) #> (g \<otimes> inv h) = (stabilizer m) #> \<one>"
      by (metis coset_join2 coset_mult_one m stabSubset stabilizer_is_subgroup subgroup.mem_carrier)
    with hinvG hG gG stabSubset have  stabgstabh:"(stabilizer m) #> g = (stabilizer m) #> h"
      by (metis coset_mult_inv1 group.coset_mult_one is_group)
    from stabSubgroup is_group U gU have "U = (stabilizer m) #> g"
      unfolding FactGroup_def by (simp add:subgroup.repr_independence2)
    also from stabgstabh is_group stabSubgroup V hV subgroup.repr_independence2 have "... = V"
      unfolding FactGroup_def by force
    finally show "U = V".
  qed
next
  have stabSubset:"stabilizer m \<subseteq> carrier G" unfolding stabilizer_def by auto
  fix H
  assume H:"H \<in> carrier (G Mod stabilizer m)"
  with rep have "rep H \<in> H" by simp
  moreover with H stabSubset have "H \<subseteq> carrier G" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
  ultimately have "rep H \<in> carrier G"..
  hence "inv rep H \<in> carrier G" by (rule inv_closed)
  with m show "\<phi> (inv rep H) m \<in> orbit m" by (auto dest:orbit_char)
next
  fix n
  assume "n \<in> orbit m"
  with m obtain g where g:"g \<in> carrier G" "\<phi> g m = n" by (auto dest:orbit_char)
  hence invg:"inv g \<in> carrier G" by simp
  hence stabinvg:"((stabilizer m) #> (inv g)) \<in> carrier (G Mod stabilizer m)" unfolding FactGroup_def RCOSETS_def by auto
  hence "rep ((stabilizer m) #> (inv g)) \<in> (stabilizer m) #> (inv g)" by (metis rep)
  then obtain h where h:"h \<in> stabilizer m" "rep ((stabilizer m) #> (inv g)) = h \<otimes> (inv g)" unfolding r_coset_def by auto
  with g have "\<phi> (inv rep ((stabilizer m) #> (inv g))) m =  \<phi> (inv (h \<otimes> (inv g))) m" by simp
  also from h have hG:"h \<in> carrier G" unfolding stabilizer_def by simp
  with g have "\<phi> (inv (h \<otimes> (inv g))) m = \<phi> (g \<otimes> (inv h)) m" by (metis inv_closed inv_inv inv_mult_group)
  also from g hG m have "... = \<phi> g (\<phi> (inv h) m)" by (metis action_mult inv_closed)
  also from h m have "inv h \<in> stabilizer m" by (metis stabilizer_is_subgroup subgroup.m_inv_closed)
  hence "\<phi> g (\<phi> (inv h) m) = \<phi> g m" unfolding stabilizer_def by simp
  also from g have "... = n" by simp
  finally have "n = \<phi> (inv rep ((stabilizer m) #> (inv g))) m"..
  with stabinvg show "n \<in> (\<lambda>H. \<phi> (inv rep H) m) ` carrier (G Mod stabilizer m)" by simp
qed

text \<open>In the case of @{term G} being finite, the last theorem can be reduced
to a statement about the cardinality of orbit and stabilizer:\<close>

corollary orbit_size:
  assumes fin:"finite (carrier G)"
  assumes m:"m \<in> M"
  shows "order G = card (orbit m) * card (stabilizer m)"
proof -
  define rep where "rep = (\<lambda>U \<in> (carrier (G Mod (stabilizer m))). SOME x. x \<in> U)"
  have "\<And>U. U \<in> (carrier (G Mod (stabilizer m))) \<Longrightarrow> rep U \<in> U"
  proof -
    fix U
    assume U:"U \<in> carrier (G Mod stabilizer m)"
    then obtain g where "g \<in> carrier G" " U = (stabilizer m) #> g" unfolding FactGroup_def RCOSETS_def by auto
    with m have "(SOME x. x \<in> U) \<in> U" by (metis rcos_self stabilizer_is_subgroup someI_ex)
    with U show "rep U \<in> U" unfolding rep_def by simp
  qed
  with m have  bij:"card (carrier (G Mod (stabilizer m))) = card (orbit m)" by (metis bij_betw_same_card orbit_thm)
  from fin m have "card (carrier (G Mod (stabilizer m))) * card (stabilizer m)  = order G" unfolding FactGroup_def by (simp add: stabilizer_is_subgroup lagrange)
  with bij show ?thesis by simp
qed

lemma orbit_not_empty:
  assumes fin:"finite M"
  assumes A:"A \<in> orbits"
  shows "card A > 0"
proof -
  from A obtain m where "m \<in> M" "A = orbit m" unfolding orbits_def quotient_def orbit_def by auto
  hence "m \<in> A" by (metis orbit_contains_rep)
  hence "A \<noteq> {}" unfolding orbits_def by auto
  moreover from fin A have "finite A" unfolding orbits_def quotient_def Image_def same_orbit_rel_def by auto
  ultimately show ?thesis by auto
qed

lemma fin_set_imp_fin_orbits:
  assumes finM:"finite M"
  shows "finite orbits"
using assms unfolding orbits_def quotient_def by simp

(*One-Element-Orbits are Fixed Points*)
lemma singleton_orbits:
  shows "\<Union>{N\<in>orbits. card N = 1} = fixed_points"
proof
  show "\<Union>{N \<in> orbits. card N = 1} \<subseteq> fixed_points"
  proof
    fix x
    assume a:"x \<in> \<Union>{N \<in> orbits. card N = 1}"
    hence "x \<in> M" unfolding orbits_def quotient_def Image_def same_orbit_rel_def by auto
    from a obtain N where N:"N \<in> orbits" "card N = 1" "x \<in> N" by auto
    then obtain y where Norbit:"N = orbit y" "y \<in> M" unfolding orbits_def quotient_def orbit_def by auto
    hence "y \<in> N" by (metis orbit_contains_rep)
    with N have Nsing:"N = {x}" "N = {y}" by (auto simp: card_Suc_eq)
    hence "x = y" by simp
    with Norbit have Norbit2:"N = orbit x" by simp
    have "{g \<in> carrier G. \<phi> g x = x} = carrier G"
    proof(auto)
      fix g
      assume "g \<in> carrier G"
      with \<open>x \<in> M\<close> have "\<phi> g x \<in> orbit x" by (auto dest:orbit_char)
      with Nsing show "\<phi> g x = x" by (metis Norbit2 singleton_iff)
    qed
    with \<open>x \<in> M\<close> show "x \<in> fixed_points" unfolding fixed_points_def stabilizer_def by simp
  qed
next
  show "fixed_points \<subseteq> \<Union>{N \<in> orbits. card N = 1}"
  proof
    fix m
    assume m:"m \<in> fixed_points"
    hence mM:"m \<in> M" unfolding fixed_points_def by simp
    hence orbit:"orbit m \<in> orbits" unfolding orbits_def quotient_def orbit_def by auto
    from mM m have "card (orbit m) = 1" by (metis singleton_orbit_eq_fixed_point)
    with orbit have "orbit m \<in> {N \<in> orbits. card N = 1}" by simp
    with mM show "m \<in> \<Union>{N \<in> orbits. card N = 1}" by (auto dest: orbit_contains_rep)
  qed
qed

text \<open>If @{term G} is a @{term p}-group acting on a finite set, a given orbit is
either a singleton or @{term p} divides its cardinality.\<close>

lemma p_dvd_orbit_size:
  assumes orderG:"order G = p ^ a"
  assumes prime:"prime p"
  assumes finM:"finite M"
  assumes Norbit:"N \<in> orbits"
  assumes "card N > 1"
  shows "p dvd card N"
proof -
  from Norbit obtain m where m:"m \<in> M" "N = orbit m"  unfolding orbits_def quotient_def orbit_def by auto
  from prime have "0 < p ^ a" by (simp add: prime_gt_0_nat)
  with orderG have "finite (carrier G)" unfolding order_def by (metis card_infinite less_nat_zero_code)
  with m have "order G = card (orbit m) * card (stabilizer m)" by (metis orbit_size)
  with orderG m have "p ^ a = card N * card (stabilizer m)" by simp
  with \<open>card N > 1\<close> show ?thesis
    by (metis dvd_mult2 dvd_mult_cancel1 nat_dvd_not_less nat_mult_1 prime
          prime_dvd_power_nat prime_factor_nat prime_nat_iff zero_less_one)
qed

text \<open>As a result of the last lemma the only orbits that count modulo
@{term p} are the fixed points\<close>

lemma fixed_point_congruence:
  assumes "order G = p ^ a"
  assumes "prime p"
  assumes finM:"finite M"
  shows "card M mod p = card fixed_points mod p"
proof -
  define big_orbits where "big_orbits = {N\<in>orbits. card N > 1}"
  from finM have orbit_part:"orbits = big_orbits \<union> {N\<in>orbits. card N = 1}" unfolding big_orbits_def by (auto dest:orbit_not_empty)
  have orbit_disj:"big_orbits \<inter> {N\<in>orbits. card N = 1} = {}" unfolding big_orbits_def by auto
  from finM have orbits_fin:"finite orbits" by (rule fin_set_imp_fin_orbits)
  hence fin_parts:"finite big_orbits" "finite {N\<in>orbits. card N = 1}" unfolding big_orbits_def by simp+
  from assms have "\<And>N. N \<in> big_orbits \<Longrightarrow> p dvd card N" unfolding big_orbits_def by (auto simp: p_dvd_orbit_size)
  hence orbit_div:"\<And>N. N \<in> big_orbits \<Longrightarrow> card N = (card N div p) * p" by (metis dvd_mult_div_cancel mult.commute)
  have "card M = card (\<Union> orbits)" unfolding orbits_def by (metis Union_quotient same_orbit_is_equiv)
  also  have "card (\<Union> orbits) = (\<Sum>N\<in>orbits. card N)" unfolding orbits_def
  proof (rule card_Union_disjoint)
    show "pairwise disjnt (M // same_orbit_rel)"
      unfolding pairwise_def disjnt_def by(metis same_orbit_is_equiv quotient_disj)
    show "\<And>A. A \<in> M // same_orbit_rel \<Longrightarrow> finite A"
      using finM same_orbit_rel_def by (auto dest:finite_equiv_class)
  qed
  also from orbit_part orbit_disj fin_parts have "... = (\<Sum>N\<in>big_orbits. card N) + (\<Sum>N\<in>{N'\<in>orbits. card N' = 1}. card N)" by (metis (lifting) sum.union_disjoint)
  also from assms orbit_div fin_parts have "... = (\<Sum>N\<in>big_orbits. (card N div p) * p) + card (\<Union>{N'\<in>orbits. card N' = 1})" by (auto simp: card_singleton_set)
  also have "... = (\<Sum>N\<in>big_orbits. card N div p) * p + card fixed_points" using singleton_orbits by (auto simp:sum_distrib_right)
  finally have "card M = (\<Sum>N\<in>big_orbits. card N div p) * p + card fixed_points".
  hence "card M mod p = ((\<Sum>N\<in>big_orbits. card N div p) * p + card fixed_points) mod p" by simp
  also have "... = (card fixed_points) mod p" by (metis mod_mult_self3)
  finally show ?thesis.
qed

text \<open>We can restrict any group action to the action of a subgroup:\<close>

lemma subgroup_action:
  assumes H:"subgroup H G"
  shows "group_action (G\<lparr>carrier := H\<rparr>) \<phi> M"
unfolding group_action_def group_action_axioms_def group_hom_def group_hom_axioms_def hom_def
using assms
proof (auto simp add: is_group subgroup.subgroup_is_group group_BijGroup)
  fix x
  assume "x \<in> H"
  with H have "x \<in> carrier G" by (metis subgroup.mem_carrier)
  with grouphom show "\<phi> x \<in> carrier (BijGroup M)" by (metis group_hom.hom_closed)
next
  fix x y
  assume x:"x \<in> H" and y:"y \<in> H"
  with H have "x \<in> carrier G" "y \<in> carrier G" by (metis subgroup.mem_carrier)+
  with grouphom show "\<phi> (x \<otimes> y) = \<phi> x \<otimes>\<^bsub>BijGroup M\<^esub> \<phi> y" by (simp add: group_hom.hom_mult)
qed

end

subsection \<open>Some Examples for Group Actions\<close>

lemma (in group) right_mult_is_bij:
  assumes h:"h \<in> carrier G"
  shows "(\<lambda>g \<in> carrier G. h \<otimes> g) \<in> Bij (carrier G)"
proof(auto simp add:Bij_def bij_betw_def inj_on_def)
  fix x y
  assume x:"x \<in> carrier G" and y:"y \<in> carrier G" and "h \<otimes> x = h \<otimes> y"
  with h show "x = y"
    by simp
next
  fix x
  assume x:"x \<in> carrier G"
  with h show "h \<otimes> x \<in> carrier G" by (metis m_closed)
  from x h have "inv h \<otimes> x \<in> carrier G" by (metis m_closed inv_closed)
  moreover from x h have "h \<otimes> (inv h \<otimes> x)  = x" by (metis inv_closed r_inv m_assoc l_one)
  ultimately show "x \<in> (\<otimes>) h ` carrier G" by force
qed

lemma (in group) right_mult_group_action:
  shows "group_action G (\<lambda>h. \<lambda>g \<in> carrier G. h \<otimes> g) (carrier G)"
unfolding group_action_def group_action_axioms_def group_hom_def group_hom_axioms_def hom_def
proof(auto simp add:is_group group_BijGroup)
  fix h
  assume "h \<in> carrier G"
  thus "(\<lambda>g \<in> carrier G. h \<otimes> g) \<in> carrier (BijGroup (carrier G))" unfolding BijGroup_def by (auto simp:right_mult_is_bij)
next
  fix x y
  assume x:"x \<in> carrier G" and y:"y \<in> carrier G"
  define multx multy
    where "multx = (\<lambda>g\<in>carrier G. x \<otimes> g)"
      and "multy = (\<lambda>g\<in>carrier G. y \<otimes> g)"
  with x y have "multx \<in> (Bij (carrier G))" "multy \<in> (Bij (carrier G))" by (metis right_mult_is_bij)+
  hence "multx \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> multy = (\<lambda>g\<in>carrier G. multx (multy g))" unfolding BijGroup_def by (auto simp: compose_def)
  also have "... = (\<lambda>g\<in>carrier G. (x \<otimes> y) \<otimes> g)" unfolding multx_def multy_def
  proof(rule restrict_ext)
    fix g
    assume g:"g \<in> carrier G"
    with x y have "x \<otimes> y \<in> carrier G" "y \<otimes> g \<in> carrier G" by simp+
    with x y g show "(\<lambda>g\<in>carrier G. x \<otimes> g) ((\<lambda>g\<in>carrier G. y \<otimes> g) g) = x \<otimes> y \<otimes> g" by (auto simp:m_assoc)
  qed
  finally show "(\<lambda>g\<in>carrier G. (x \<otimes> y) \<otimes> g) = (\<lambda>g\<in>carrier G. x \<otimes> g) \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> (\<lambda>g\<in>carrier G. y \<otimes> g)" unfolding multx_def multy_def by simp
qed

lemma (in group) rcosets_closed:
  assumes HG:"subgroup H G"
  assumes g:"g \<in> carrier G"
  assumes M:"M \<in> rcosets H"
  shows "M #> g \<in> rcosets H"
proof -
  from M obtain h where h:"h \<in> carrier G" "M = H #> h" unfolding RCOSETS_def by auto
  with g HG have "M #> g = H #> (h \<otimes> g)" by (metis coset_mult_assoc subgroup.subset)
  with HG g h show "M #> g \<in> rcosets H" by (metis rcosetsI subgroup.m_closed subgroup.subset subgroup_self)
qed

lemma (in group) inv_mult_on_rcosets_is_bij:
  assumes HG:"subgroup H G"
  assumes g:"g \<in> carrier G"
  shows "(\<lambda>U \<in> rcosets H. U #> inv g) \<in> Bij (rcosets H)"
proof(auto simp add:Bij_def bij_betw_def inj_on_def)
  fix M
  assume "M \<in> rcosets H"
  with HG g show "M #> inv g \<in> rcosets H" by (metis inv_closed rcosets_closed)
next
  fix M
  assume M:"M \<in> rcosets H"
  with HG g have "M #> g \<in> rcosets H" by (rule rcosets_closed)
  moreover from M HG g have "M #> g #> inv g = M" by (metis coset_mult_assoc coset_mult_inv2 inv_closed is_group subgroup.rcosets_carrier)
  ultimately show " M \<in> (\<lambda>U. U #> inv g) ` (rcosets H)" by auto
next
  fix M N x
  assume M:"M \<in> rcosets H" and N:"N \<in> rcosets H" and "M #> inv g = N #> inv g"
  hence "(M #> inv g) #> g = (N #> inv g) #> g" by simp
  with HG M N g have "M #> (inv g \<otimes> g) = N #> (inv g \<otimes> g)" by (metis coset_mult_assoc is_group subgroup.m_inv_closed subgroup.rcosets_carrier subgroup_self)
  with HG M N g have a1:"M = N" by (metis l_inv coset_mult_one is_group subgroup.rcosets_carrier)
  {
    assume "x \<in> M"
    with a1 show "x \<in> N" by simp
  }
  {
    assume "x \<in> N"
    with a1 show "x \<in> M" by simp
  }
qed

lemma (in group) inv_mult_on_rcosets_action:
  assumes HG:"subgroup H G"
  shows "group_action G (\<lambda>g. \<lambda>U \<in> rcosets H. U #> inv g) (rcosets H)"
unfolding group_action_def group_action_axioms_def group_hom_def group_hom_axioms_def hom_def
proof(auto simp add:is_group group_BijGroup)
  fix h
  assume "h \<in> carrier G"
  with HG show "(\<lambda>U \<in> rcosets H. U #> inv h) \<in> carrier (BijGroup (rcosets H))"
    unfolding BijGroup_def by (auto simp:inv_mult_on_rcosets_is_bij)
next
  fix x y
  assume x:"x \<in> carrier G" and y:"y \<in> carrier G"
  define cosx cosy
    where "cosx = (\<lambda>U\<in>rcosets H. U #> inv x)"
      and "cosy = (\<lambda>U\<in>rcosets H. U #> inv y)"
  with x y HG have "cosx \<in> (Bij (rcosets H))" "cosy \<in> (Bij (rcosets H))"
    by (metis inv_mult_on_rcosets_is_bij)+
  hence "cosx \<otimes>\<^bsub>BijGroup (rcosets H)\<^esub> cosy = (\<lambda>U\<in>rcosets H. cosx (cosy U))"
    unfolding BijGroup_def by (auto simp: compose_def)
  also have "... = (\<lambda>U\<in>rcosets H. U #> inv (x \<otimes> y))" unfolding cosx_def cosy_def
  proof(rule restrict_ext)
    fix U
    assume U:"U \<in> rcosets H"
    with HG y have "U #> inv y \<in> rcosets H" by (metis inv_closed rcosets_closed)
    with x y HG U have "(\<lambda>U\<in>rcosets H. U #> inv x) ((\<lambda>U\<in>rcosets H. U #> inv y) U) = U #> inv y #> inv x"
      by auto
    also from x y U HG have "... = U #> inv (x \<otimes> y)"
      by (metis inv_mult_group coset_mult_assoc inv_closed is_group subgroup.rcosets_carrier)
    finally show "(\<lambda>U\<in>rcosets H. U #> inv x) ((\<lambda>U\<in>rcosets H. U #> inv y) U) = U #> inv (x \<otimes> y)".
  qed
  finally show "(\<lambda>U\<in>rcosets H. U #> inv (x \<otimes> y)) = (\<lambda>U\<in>rcosets H. U #> inv x) \<otimes>\<^bsub>BijGroup (rcosets H)\<^esub> (\<lambda>U\<in>rcosets H. U #> inv y)"
    unfolding cosx_def cosy_def by simp
qed

end


section \<open> General Extensional Mereology \<close>

(*<*)
theory GEM
  imports GMM CEM
begin (*>*)

text \<open> The theory of \emph{general extensional mereology}, also known as \emph{classical extensional
mereology} adds general mereology to extensional mereology.\footnote{For this axiomatization see
@{cite "varzi_parts_1996"} p. 265  and @{cite "casati_parts_1999"} p. 46.} \<close>

locale GEM = GM + EM +
  assumes sum_eq: "x \<oplus> y = (THE z. \<forall>v. O v z \<longleftrightarrow> O v x \<or> O v y)"
  assumes product_eq:
    "x \<otimes> y = (THE z. \<forall>v. P v z \<longleftrightarrow> P v x \<and> P v y)"
  assumes difference_eq:
    "x \<ominus> y = (THE z. \<forall>w. P w z = (P w x \<and> \<not> O w y))"
  assumes complement_eq: "\<midarrow> x = (THE z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
  assumes universe_eq: "u = (THE x. \<forall>y. P y x)"
  assumes fusion_eq: "\<exists>x. F x \<Longrightarrow>
    (\<sigma> x. F x) = (THE x. \<forall>y. O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z))"
  assumes general_product_eq: "(\<pi> x. F x) = (\<sigma> x. \<forall>y. F y \<longrightarrow> P x y)"

sublocale GEM \<subseteq> GMM
proof
qed

subsection \<open> General Sums  \<close>

context GEM
begin

lemma fusion_intro:
"(\<forall>y. O y z \<longleftrightarrow> (\<exists>x. F x \<and> O y x)) \<Longrightarrow> (\<sigma> x. F x) = z"
proof -
  assume antecedent: "(\<forall>y. O y z \<longleftrightarrow> (\<exists>x. F x \<and> O y x))"
  hence "(THE x. \<forall>y. O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z)) = z"
  proof (rule the_equality)
    fix a
    assume a: "(\<forall>y. O y a \<longleftrightarrow> (\<exists>x. F x \<and> O y x))"
    have "\<forall>x. O x a \<longleftrightarrow> O x z"
    proof
      fix b
      from antecedent have "O b z \<longleftrightarrow> (\<exists>x. F x \<and> O b x)"..
      moreover from a have "O b a \<longleftrightarrow> (\<exists>x. F x \<and> O b x)"..
      ultimately show "O b a \<longleftrightarrow> O b z" by (rule ssubst)
    qed
    with overlap_extensionality show "a = z"..
  qed
  moreover from antecedent have "O z z \<longleftrightarrow> (\<exists>x. F x \<and> O z x)"..
  hence "\<exists>x. F x \<and> O z x" using overlap_reflexivity..
  hence "\<exists>x. F x" by auto
  hence "(\<sigma> x. F x) = (THE x. \<forall>y. O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z))"
    by (rule fusion_eq)
  ultimately show "(\<sigma> v. F v) = z" by (rule subst)
qed

lemma fusion_idempotence: "(\<sigma> x. z = x) = z"
proof -
  have "\<forall>y. O y z \<longleftrightarrow> (\<exists>x. z = x \<and> O y x)"
  proof
    fix y
    show "O y z \<longleftrightarrow> (\<exists>x. z = x \<and> O y x)"
    proof
      assume "O y z"
      with refl have "z = z \<and> O y z"..
      thus "\<exists>x. z = x \<and> O y x"..
    next
      assume "\<exists>x. z = x \<and> O y x"
      then obtain x where x: "z = x \<and> O y x"..
      hence "z = x"..
      moreover from x have "O y x"..
      ultimately show "O y z" by (rule ssubst)
    qed
  qed
  thus "(\<sigma> x. z = x) = z"
    by (rule fusion_intro)
qed

text \<open> The whole is the sum of its parts. \<close>

lemma fusion_absorption: "(\<sigma> x. P x z) = z"
proof -
  have "(\<forall>y. O y z \<longleftrightarrow> (\<exists>x. P x z \<and> O y x))"
  proof
    fix y
    show "O y z \<longleftrightarrow> (\<exists>x. P x z \<and> O y x)"
    proof
      assume "O y z"
      with part_reflexivity have "P z z \<and> O y z"..
      thus "\<exists>x. P x z \<and> O y x"..
    next
      assume "\<exists>x. P x z \<and> O y x"
      then obtain x where x: "P x z \<and> O y x"..
      hence "P x z"..
      moreover from x have "O y x"..
      ultimately show "O y z" by (rule overlap_monotonicity)
    qed
  qed
  thus "(\<sigma> x. P x z) = z"
    by (rule fusion_intro)
qed

lemma part_fusion: "P w (\<sigma> v. P v x) \<Longrightarrow> P w x"
proof -
  assume "P w (\<sigma> v. P v x)"
  with fusion_absorption show "P w x" by (rule subst)
qed

lemma fusion_character:
  "\<exists>x. F x \<Longrightarrow> (\<forall>y. O y (\<sigma> v. F v) \<longleftrightarrow> (\<exists>x. F x \<and> O y x))"
proof -
  assume "\<exists>x. F x"
  hence "\<exists>z. \<forall>y. O y z \<longleftrightarrow> (\<exists>x. F x \<and> O y x)"
    by (rule fusion)
  then obtain z where z: "\<forall>y. O y z \<longleftrightarrow> (\<exists>x. F x \<and> O y x)"..
  hence "(\<sigma> v. F v) = z " by (rule fusion_intro)
  thus "\<forall>y. O y (\<sigma> v. F v) \<longleftrightarrow> (\<exists>x. F x \<and> O y x)" using z by (rule ssubst)
qed

text \<open> The next lemma characterises fusions in terms of parthood.\footnote{See @{cite "pontow_note_2004"} pp. 202-9.} \<close>

lemma fusion_part_character: "\<exists>x. F x \<Longrightarrow>
  (\<forall>y. P y (\<sigma> v. F v) \<longleftrightarrow> (\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v)))"
proof -
  assume "(\<exists>x. F x)"
  hence F: "\<forall>y. O y (\<sigma> v. F v) \<longleftrightarrow> (\<exists>x. F x \<and> O y x)"
    by (rule fusion_character)
  show "\<forall>y. P y (\<sigma> v. F v) \<longleftrightarrow> (\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v))"
  proof
    fix y
    show "P y (\<sigma> v. F v) \<longleftrightarrow> (\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v))"
    proof
      assume "P y (\<sigma> v. F v)"
      show "\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v)"
      proof
        fix w
        from F have w: "O w (\<sigma> v. F v) \<longleftrightarrow> (\<exists>x. F x \<and> O w x)"..
        show "P w y \<longrightarrow> (\<exists>v. F v \<and> O w v)"
        proof
          assume "P w y"
          hence "P w (\<sigma> v. F v)" using `P y (\<sigma> v. F v)`
            by (rule part_transitivity)
          hence "O w (\<sigma> v. F v)" by (rule part_implies_overlap)
          with w show "\<exists>x. F x \<and> O w x"..
        qed
      qed
    next
      assume right: "\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v)"
      show "P y (\<sigma> v. F v)"
      proof (rule ccontr)
        assume "\<not> P y (\<sigma> v. F v)"
        hence "\<exists>v. P v y \<and> \<not> O v (\<sigma> v. F v)"
          by (rule strong_supplementation)
        then obtain v where v: "P v y \<and> \<not> O v (\<sigma> v. F v)"..
        hence "\<not> O v (\<sigma> v. F v)"..
        from right have "P v y \<longrightarrow> (\<exists>w. F w \<and> O v w)"..
        moreover from v have "P v y"..
        ultimately have "\<exists>w. F w \<and> O v w"..
        from F have "O v (\<sigma> v. F v) \<longleftrightarrow> (\<exists>x. F x \<and> O v x)"..
        hence "O v (\<sigma> v. F v)" using `\<exists>w. F w \<and> O v w`..
        with `\<not> O v (\<sigma> v. F v)` show "False"..
      qed
    qed
  qed
qed

lemma fusion_part: "F x \<Longrightarrow> P x (\<sigma> x. F x)"
proof -
  assume "F x"
  hence "\<exists>x. F x"..
  hence "\<forall>y. P y (\<sigma> v. F v) \<longleftrightarrow> (\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v))"
    by (rule fusion_part_character)
  hence "P x (\<sigma> v. F v) \<longleftrightarrow> (\<forall>w. P w x \<longrightarrow> (\<exists>v. F v \<and> O w v))"..
  moreover have "\<forall>w. P w x \<longrightarrow> (\<exists>v. F v \<and> O w v)"
  proof
    fix w
    show "P w x \<longrightarrow> (\<exists>v. F v \<and> O w v)"
    proof
      assume "P w x"
      hence "O w x" by (rule part_implies_overlap)
      with `F x` have "F x \<and> O w x"..
      thus "\<exists>v. F v \<and> O w v"..
    qed
  qed
  ultimately show "P x (\<sigma> v. F v)"..
qed

lemma common_part_fusion:
  "O x y \<Longrightarrow> (\<forall>w. P w (\<sigma> v. (P v x \<and> P v y)) \<longleftrightarrow> (P w x \<and> P w y))"
proof -
  assume "O x y"
  with overlap_eq have "\<exists>z. (P z x \<and> P z y)"..
  hence sum: "(\<forall>w. P w (\<sigma> v. (P v x \<and> P v y)) \<longleftrightarrow>
    (\<forall>z. P z w \<longrightarrow> (\<exists>v. (P v x \<and> P v y) \<and> O z v)))"
    by (rule fusion_part_character)
  show "\<forall>w. P w (\<sigma> v. (P v x \<and> P v y)) \<longleftrightarrow> (P w x \<and> P w y)"
  proof
    fix w
    from sum have w: "P w (\<sigma> v. (P v x \<and> P v y))
      \<longleftrightarrow> (\<forall>z. P z w \<longrightarrow> (\<exists>v. (P v x \<and> P v y) \<and> O z v))"..
    show "P w (\<sigma> v. (P v x \<and> P v y)) \<longleftrightarrow> (P w x \<and> P w y)"
    proof
      assume "P w (\<sigma> v. (P v x \<and> P v y))"
      with w have bla:
        "(\<forall>z. P z w \<longrightarrow> (\<exists>v. (P v x \<and> P v y) \<and> O z v))"..
      show "P w x \<and> P w y"
      proof
        show "P w x"
        proof (rule ccontr)
          assume "\<not> P w x"
          hence "\<exists>z. P z w \<and> \<not> O z x"
            by (rule strong_supplementation)
          then obtain z where z: "P z w \<and> \<not> O z x"..
          hence "\<not> O z x"..
          from bla have "P z w \<longrightarrow> (\<exists>v. (P v x \<and> P v y) \<and> O z v)"..
          moreover from z have "P z w"..
          ultimately have "\<exists>v. (P v x \<and> P v y) \<and> O z v"..
          then obtain v where v: "(P v x \<and> P v y) \<and> O z v"..
          hence "P v x \<and> P v y"..
          hence "P v x"..
          moreover from v have "O z v"..
          ultimately have "O z x"
            by (rule overlap_monotonicity)
          with `\<not> O z x` show "False"..
        qed
        show "P w y"
        proof (rule ccontr)
          assume "\<not> P w y"
          hence "\<exists>z. P z w \<and> \<not> O z y"
            by (rule strong_supplementation)
          then obtain z where z: "P z w \<and> \<not> O z y"..
          hence "\<not> O z y"..
          from bla have "P z w \<longrightarrow> (\<exists>v. (P v x \<and> P v y) \<and> O z v)"..
          moreover from z have "P z w"..
          ultimately have "\<exists>v. (P v x \<and> P v y) \<and> O z v"..
          then obtain v where v: "(P v x \<and> P v y) \<and> O z v"..
          hence "P v x \<and> P v y"..
          hence "P v y"..
          moreover from v have "O z v"..
          ultimately have "O z y"
            by (rule overlap_monotonicity)
          with `\<not> O z y` show "False"..
        qed
      qed
    next
      assume "P w x \<and> P w y"
      thus "P w (\<sigma> v. (P v x \<and> P v y))"
        by (rule fusion_part)
    qed
  qed
qed

theorem product_closure:
  "O x y \<Longrightarrow> (\<exists>z. \<forall>w. P w z \<longleftrightarrow> (P w x \<and> P w y))"
proof -
  assume "O x y"
  hence "(\<forall>w. P w (\<sigma> v. (P v x \<and> P v y)) \<longleftrightarrow> (P w x \<and> P w y))"
    by (rule common_part_fusion)
  thus "\<exists>z. \<forall>w. P w z \<longleftrightarrow> (P w x \<and> P w y)"..
qed

end

sublocale GEM \<subseteq> CEM
proof
  fix x y
  show "\<exists>z. \<forall>w. O w z = (O w x \<or> O w y)"
    using sum_closure.
  show "x \<oplus> y = (THE z. \<forall>v. O v z \<longleftrightarrow> O v x \<or> O v y)"
    using sum_eq.
  show "x \<otimes> y = (THE z. \<forall>v. P v z \<longleftrightarrow> P v x \<and> P v y)"
    using product_eq.
  show "O x y \<Longrightarrow> (\<exists>z. \<forall>w. P w z = (P w x \<and> P w y))"
    using product_closure.
qed

context GEM
begin

corollary "O x y \<Longrightarrow> x \<otimes> y = (\<sigma> v. P v x \<and> P v y)"
proof -
  assume "O x y"
  hence "(\<forall>w. P w (\<sigma> v. (P v x \<and> P v y)) \<longleftrightarrow> (P w x \<and> P w y))"
    by (rule common_part_fusion)
  thus "x \<otimes> y = (\<sigma> v. P v x \<and> P v y)" by (rule product_intro)
qed

lemma disjoint_fusion:
  "\<exists>w. \<not> O w x \<Longrightarrow> (\<forall>w. P w (\<sigma> z. \<not> O z x) \<longleftrightarrow> \<not> O w x)"
proof -
  assume antecedent: "\<exists>w. \<not> O w x"
  hence "\<forall>y. O y (\<sigma> v. \<not> O v x) \<longleftrightarrow> (\<exists>v. \<not> O v x \<and> O y v)"
    by (rule fusion_character)
  hence x: "O x (\<sigma> v. \<not> O v x) \<longleftrightarrow> (\<exists>v. \<not> O v x \<and> O x v)"..
  show "\<forall>w. P w (\<sigma> z. \<not> O z x) \<longleftrightarrow> \<not> O w x"
  proof
    fix y
    show "P y (\<sigma> z. \<not> O z x) \<longleftrightarrow> \<not> O y x"
    proof
      assume "P y (\<sigma> z. \<not> O z x)"
      moreover have "\<not> O x (\<sigma> z. \<not> O z x)"
      proof
        assume "O x (\<sigma> z. \<not> O z x)"
        with x have "(\<exists>v. \<not> O v x \<and> O x v)"..
        then obtain v where v: "\<not> O v x \<and> O x v"..
        hence "\<not> O v x"..
        from v have "O x v"..
        hence "O v x" by (rule overlap_symmetry)
        with `\<not> O v x` show "False"..
      qed
      ultimately have "\<not> O x y"
        by (rule disjoint_demonotonicity)
      thus "\<not> O y x" by (rule disjoint_symmetry)
    next
      assume "\<not> O y x"
      thus "P y (\<sigma> v. \<not> O v x)"
        by (rule fusion_part)
    qed
  qed
qed

theorem complement_closure:
  "\<exists>w. \<not> O w x \<Longrightarrow> (\<exists>z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
proof -
  assume "(\<exists>w. \<not> O w x)"
  hence "\<forall>w. P w (\<sigma> z. \<not> O z x) \<longleftrightarrow> \<not> O w x"
    by (rule disjoint_fusion)
  thus "\<exists>z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x"..
qed

end

sublocale GEM \<subseteq> CEMC
proof
  fix x y
  show "\<midarrow> x = (THE z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
    using complement_eq.
  show "(\<exists>w. \<not> O w x) \<Longrightarrow> (\<exists>z. \<forall>w. P w z = (\<not> O w x))"
    using complement_closure.
  show "x \<ominus> y = (THE z. \<forall>w. P w z = (P w x \<and> \<not> O w y))"
    using difference_eq.
  show "u = (THE x. \<forall>y. P y x)"
    using universe_eq.
qed

context GEM
begin

corollary complement_is_disjoint_fusion:
  "\<exists>w. \<not> O w x \<Longrightarrow> \<midarrow> x = (\<sigma> z. \<not> O z x)"
proof -
  assume "\<exists>w. \<not> O w x"
  hence "\<forall>w. P w (\<sigma> z. \<not> O z x) \<longleftrightarrow> \<not> O w x"
    by (rule disjoint_fusion)
  thus "\<midarrow> x = (\<sigma> z. \<not> O z x)"
    by (rule complement_intro)
qed

theorem strong_fusion: "\<exists>x. F x \<Longrightarrow>
  \<exists>x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))"
proof -
  assume "\<exists>x. F x"
  have "(\<forall>y. F y \<longrightarrow> P y (\<sigma> v. F v)) \<and>
     (\<forall>y. P y (\<sigma> v. F v) \<longrightarrow> (\<exists>z. F z \<and> O y z))"
  proof
    show "\<forall>y. F y \<longrightarrow> P y (\<sigma> v. F v)"
    proof
      fix y
      show "F y \<longrightarrow> P y (\<sigma> v. F v)"
      proof
        assume "F y"
        thus "P y (\<sigma> v. F v)"
          by (rule fusion_part)
      qed
    qed
  next
    have "(\<forall>y. P y (\<sigma> v. F v) \<longleftrightarrow>
      (\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v)))"
      using `\<exists>x. F x` by (rule fusion_part_character)
    hence "P (\<sigma> v. F v) (\<sigma> v. F v) \<longleftrightarrow> (\<forall>w. P w (\<sigma> v. F v) \<longrightarrow>
      (\<exists>v. F v \<and> O w v))"..
    thus "\<forall>w. P w (\<sigma> v. F v) \<longrightarrow> (\<exists>v. F v \<and> O w v)" using part_reflexivity..
  qed
  thus ?thesis..
qed

theorem strong_fusion_eq: "\<exists>x. F x \<Longrightarrow> (\<sigma> x. F x) =
  (THE x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)))"
proof -
  assume "\<exists>x. F x"
  have "(THE x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))) = (\<sigma> x. F x)"
  proof (rule the_equality)
    show "(\<forall>y. F y \<longrightarrow> P y (\<sigma> x. F x)) \<and> (\<forall>y. P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z))"
    proof
      show "\<forall>y. F y \<longrightarrow> P y (\<sigma> x. F x)"
      proof
        fix y
        show "F y \<longrightarrow> P y (\<sigma> x. F x)"
        proof
          assume "F y"
          thus "P y (\<sigma> x. F x)"
            by (rule fusion_part)
        qed
      qed
    next
      show "(\<forall>y. P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z))"
      proof
        fix y
        show "P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z)"
        proof
          have  "\<forall>y. P y (\<sigma> v. F v) \<longleftrightarrow> (\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v))"
            using `\<exists>x. F x` by (rule fusion_part_character)
          hence "P y (\<sigma> v. F v) \<longleftrightarrow> (\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v))"..
          moreover assume "P y (\<sigma> x. F x)"
          ultimately have "\<forall>w. P w y \<longrightarrow> (\<exists>v. F v \<and> O w v)"..
          hence "P y y \<longrightarrow> (\<exists>v. F v \<and> O y v)"..
          thus "\<exists>v. F v \<and> O y v" using part_reflexivity..
        qed
      qed
    qed
  next
    fix x
    assume x: "(\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))"
    have "\<forall>y. O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z)"
    proof
      fix y
      show "O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z)"
      proof
        assume "O y x"
        with overlap_eq have "\<exists>v. P v y \<and> P v x"..
        then obtain v where v: "P v y \<and> P v x"..
        from x have "\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)"..
        hence "P v x \<longrightarrow> (\<exists>z. F z \<and> O v z)"..
        moreover from v have "P v x"..
        ultimately have "\<exists>z. F z \<and> O v z"..
        then obtain z where z: "F z \<and> O v z"..
        hence "F z"..
        from v have "P v y"..
        moreover from z have "O v z"..
        hence "O z v" by (rule overlap_symmetry)
        ultimately have "O z y" by (rule overlap_monotonicity)
        hence "O y z" by (rule overlap_symmetry)
        with `F z` have "F z \<and> O y z"..
        thus "\<exists>z. F z \<and> O y z"..
      next
        assume "\<exists>z. F z \<and> O y z"
        then obtain z where z: "F z \<and> O y z"..
        from x have "\<forall>y. F y \<longrightarrow> P y x"..
        hence "F z \<longrightarrow> P z x"..
        moreover from z have "F z"..
        ultimately have "P z x"..
        moreover from z have "O y z"..
        ultimately show "O y x"
          by (rule overlap_monotonicity)
      qed
    qed
    hence "(\<sigma> x. F x) = x"
      by (rule fusion_intro)
    thus "x = (\<sigma> x. F x)"..
  qed
  thus ?thesis..
qed

lemma strong_sum_eq: "x \<oplus> y = (THE z. (P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y))"
proof -
  have "(THE z. (P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)) = x \<oplus> y"
  proof (rule the_equality)
    show "(P x (x \<oplus> y) \<and> P y (x \<oplus> y)) \<and> (\<forall>w. P w (x \<oplus> y) \<longrightarrow> O w x \<or> O w y)"
    proof
      show "P x (x \<oplus> y) \<and> P y (x \<oplus> y)"
        proof
          show "P x (x \<oplus> y)" using first_summand_in_sum.
          show "P y (x \<oplus> y)" using second_summand_in_sum.
        qed
      show "\<forall>w. P w (x \<oplus> y) \<longrightarrow> O w x \<or> O w y"
      proof
        fix w
        show "P w (x \<oplus> y) \<longrightarrow> O w x \<or> O w y"
        proof
          assume "P w (x \<oplus> y)"
          hence "O w (x \<oplus> y)" by (rule part_implies_overlap)
          with sum_overlap show "O w x \<or> O w y"..
        qed
      qed
    qed
    fix z
    assume z: "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)"
    hence "P x z \<and> P y z"..
    have "\<forall>w. O w z \<longleftrightarrow> (O w x \<or> O w y)"
    proof
      fix w
      show "O w z \<longleftrightarrow> (O w x \<or> O w y)"
      proof
        assume "O w z"
        with overlap_eq have "\<exists>v. P v w \<and> P v z"..
        then obtain v where v: "P v w \<and> P v z"..
        hence "P v w"..
        from z have "\<forall>w. P w z \<longrightarrow> O w x \<or> O w y"..
        hence "P v z \<longrightarrow> O v x \<or> O v y"..
        moreover from v have "P v z"..
        ultimately have "O v x \<or> O v y"..
        thus "O w x \<or> O w y"
        proof
          assume "O v x"
          hence "O x v" by (rule overlap_symmetry)
          with `P v w` have "O x w" by (rule overlap_monotonicity)
          hence "O w x" by (rule overlap_symmetry)
          thus "O w x \<or> O w y"..
        next
          assume "O v y"
          hence "O y v" by (rule overlap_symmetry)
          with `P v w` have "O y w" by (rule overlap_monotonicity)
          hence "O w y" by (rule overlap_symmetry)
          thus "O w x \<or> O w y"..
        qed
      next
        assume "O w x \<or> O w y"
        thus "O w z"
        proof
          from `P x z \<and> P y z` have "P x z"..
          moreover assume "O w x"
          ultimately show "O w z"
            by (rule overlap_monotonicity)
        next
          from `P x z \<and> P y z` have "P y z"..
          moreover assume "O w y"
          ultimately show "O w z"
            by (rule overlap_monotonicity)
        qed
      qed
    qed
    hence "x \<oplus> y = z" by (rule sum_intro)
    thus "z = x \<oplus> y"..
  qed
  thus ?thesis..
qed

subsection \<open> General Products \<close>

lemma general_product_intro: "(\<forall>y. O y x \<longleftrightarrow> (\<exists>z. (\<forall>y. F y \<longrightarrow> P z y) \<and> O y z)) \<Longrightarrow> (\<pi> x. F x) = x"
proof -
  assume "\<forall>y. O y x \<longleftrightarrow> (\<exists>z. (\<forall>y. F y \<longrightarrow> P z y) \<and> O y z)"
  hence "(\<sigma> x. \<forall>y. F y \<longrightarrow> P x y) = x" by (rule fusion_intro)
  with general_product_eq show "(\<pi> x. F x) = x" by (rule ssubst)
qed

lemma general_product_idempotence: "(\<pi> z. z = x) = x"
proof -
  have "\<forall>y. O y x \<longleftrightarrow> (\<exists>z. (\<forall>y. y = x \<longrightarrow> P z y) \<and> O y z)"
    by (meson overlap_eq part_reflexivity part_transitivity)
  thus "(\<pi> z. z = x) = x" by (rule general_product_intro)
qed

lemma general_product_absorption: "(\<pi> z. P x z) = x"
proof -
  have "\<forall>y. O y x \<longleftrightarrow> (\<exists>z. (\<forall>y. P x y \<longrightarrow> P z y) \<and> O y z)"
    by (meson overlap_eq part_reflexivity part_transitivity)
  thus "(\<pi> z. P x z) = x" by (rule general_product_intro)
qed

lemma general_product_character: "\<exists>z. \<forall>y. F y \<longrightarrow> P z y \<Longrightarrow>
  \<forall>y. O y (\<pi> x. F x) \<longleftrightarrow> (\<exists>z. (\<forall>y. F y \<longrightarrow> P z y) \<and> O y z)"
proof -
  assume "(\<exists>z. \<forall>y. F y \<longrightarrow> P z y)"
  hence "(\<exists>x. \<forall>y. O y x \<longleftrightarrow> (\<exists>z. (\<forall>y. F y \<longrightarrow> P z y) \<and> O y z))"
    by (rule fusion)
  then obtain x where x:
    "\<forall>y. O y x \<longleftrightarrow> (\<exists>z. (\<forall>y. F y \<longrightarrow> P z y) \<and> O y z)"..
  hence "(\<pi> x. F x) = x" by (rule general_product_intro)
  thus "(\<forall>y. O y (\<pi> x. F x) \<longleftrightarrow> (\<exists>z. (\<forall>y. F y \<longrightarrow> P z y) \<and> O y z))"
    using x by (rule ssubst)
qed

corollary "\<not> (\<exists>x. F x) \<Longrightarrow> u = (\<pi> x. F x)"
proof -
  assume antecedent: "\<not> (\<exists>x. F x)"
  have "\<forall>y. P y (\<pi> x. F x)"
  proof
    fix y
    show "P y (\<pi> x. F x)"
    proof (rule ccontr)
      assume "\<not> P y (\<pi> x. F x)"
     hence "\<exists>z. P z y \<and> \<not> O z (\<pi> x. F x)" by (rule strong_supplementation)
      then obtain z where z: "P z y \<and> \<not> O z (\<pi> x. F x)"..
      hence "\<not> O z (\<pi> x. F x)"..
      from antecedent have bla: "\<forall> y. F y \<longrightarrow> P z y" by simp
      hence "\<exists> v. \<forall> y. F y \<longrightarrow> P v y"..
      hence "(\<forall>y. O y (\<pi> x. F x) \<longleftrightarrow> (\<exists>z. (\<forall>y. F y \<longrightarrow> P z y) \<and> O y z))" by (rule general_product_character)
      hence "O z (\<pi> x. F x) \<longleftrightarrow> (\<exists>v. (\<forall>y. F y \<longrightarrow> P v y) \<and> O z v)"..
      moreover from bla have  "(\<forall> y. F y \<longrightarrow> P z y) \<and> O z z"
        using overlap_reflexivity..
      hence "\<exists> v. (\<forall> y. F y \<longrightarrow> P v y) \<and> O z v"..
      ultimately have "O z (\<pi> x. F x)"..
      with `\<not> O z (\<pi> x. F x)` show "False"..
    qed
  qed
  thus "u = (\<pi> x. F x)"
    by (rule universe_intro)
qed

end

subsection \<open> Strong Fusion \<close>

text \<open> An alternative axiomatization of general extensional mereology adds a stronger version of the
fusion axiom to minimal mereology, with correspondingly stronger definitions of sums and general
sums.\footnote{See @{cite "tarski_foundations_1983"} p. 25. The proofs in this section are adapted
from @{cite "hovda_what_2009"}.} \<close>

locale GEM1 = MM +
  assumes strong_fusion: "\<exists>x. F x \<Longrightarrow> \<exists>x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))"
  assumes strong_sum_eq: "x \<oplus> y = (THE z. (P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y))"
  assumes product_eq:
    "x \<otimes> y = (THE z. \<forall>v. P v z \<longleftrightarrow> P v x \<and> P v y)"
  assumes difference_eq:
    "x \<ominus> y = (THE z. \<forall>w. P w z = (P w x \<and> \<not> O w y))"
  assumes complement_eq: "\<midarrow> x = (THE z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
  assumes universe_eq: "u = (THE x. \<forall>y. P y x)"
  assumes strong_fusion_eq:  "\<exists>x. F x \<Longrightarrow> (\<sigma> x. F x) = (THE x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)))"
  assumes general_product_eq: "(\<pi> x. F x) = (\<sigma> x. \<forall>y. F y \<longrightarrow> P x y)"
begin

theorem fusion:
  "\<exists>x. \<phi> x \<Longrightarrow> (\<exists>z. \<forall>y. O y z \<longleftrightarrow> (\<exists>x. \<phi> x \<and> O y x))"
proof -
  assume "\<exists>x. \<phi> x"
  hence "\<exists>x. (\<forall>y. \<phi> y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. \<phi> z \<and> O y z))" by (rule strong_fusion)
  then obtain x where x:
    "(\<forall>y. \<phi> y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. \<phi> z \<and> O y z))"..
  have "\<forall>y. O y x \<longleftrightarrow> (\<exists>v. \<phi> v \<and> O y v)"
  proof
    fix y
    show "O y x \<longleftrightarrow> (\<exists>v. \<phi> v \<and> O y v)"
    proof
      assume "O y x"
      with overlap_eq have "\<exists>z. P z y \<and> P z x"..
      then obtain z where z: "P z y \<and> P z x"..
      hence "P z x"..
      from x have "\<forall>y. P y x \<longrightarrow> (\<exists>v. \<phi> v \<and> O y v)"..
      hence "P z x \<longrightarrow> (\<exists>v. \<phi> v \<and> O z v)"..
      hence "\<exists>v. \<phi> v \<and> O z v" using `P z x`..
      then obtain v where v: "\<phi> v \<and> O z v"..
      hence "O z v"..
      with overlap_eq have "\<exists>w. P w z \<and> P w v"..
      then obtain w where w: "P w z \<and> P w v"..
      hence "P w z"..
      moreover from z have "P z y"..
      ultimately have "P w y"
        by (rule part_transitivity)
      moreover from w have "P w v"..
      ultimately have "P w y \<and> P w v"..
      hence "\<exists>w. P w y \<and> P w v"..
      with overlap_eq have "O y v"..
      from v have "\<phi> v"..
      hence "\<phi> v \<and> O y v" using `O y v`..
      thus "\<exists>v. \<phi> v \<and> O y v"..
    next
      assume "\<exists>v. \<phi> v \<and> O y v"
      then obtain v where v: "\<phi> v \<and> O y v"..
      hence "O y v"..
      with overlap_eq have "\<exists>z. P z y \<and> P z v"..
      then obtain z where z: "P z y \<and> P z v"..
      hence "P z v"..
      from x have "\<forall>y. \<phi> y \<longrightarrow> P y x"..
      hence "\<phi> v \<longrightarrow> P v x"..
      moreover from v have "\<phi> v"..
      ultimately have "P v x"..
      with `P z v` have "P z x"
        by (rule part_transitivity)
      from z have "P z y"..
      thus "O y x" using `P z x`
        by (rule overlap_intro)
    qed
  qed
  thus "(\<exists>z. \<forall>y. O y z \<longleftrightarrow> (\<exists>x. \<phi> x \<and> O y x))"..
qed

lemma pair: "\<exists>v. (\<forall>w. (w = x \<or> w = y) \<longrightarrow> P w v) \<and> (\<forall>w. P w v \<longrightarrow> (\<exists>z. (z = x \<or> z = y) \<and> O w z))"
proof -
  have "x = x"..
  hence "x = x \<or> x = y"..
  hence "\<exists>v. v = x \<or> v = y"..
  thus ?thesis
    by (rule strong_fusion)
qed

lemma or_id: "(v = x \<or> v = y) \<and> O w v \<Longrightarrow> O w x \<or> O w y"
proof -
  assume v: "(v = x \<or> v = y) \<and> O w v"
  hence "O w v"..
  from v have "v = x \<or> v = y"..
  thus "O w x \<or> O w y"
  proof
    assume "v = x"
    hence "O w x" using `O w v` by (rule subst)
    thus "O w x \<or> O w y"..
  next
    assume "v = y"
    hence "O w y" using `O w v` by (rule subst)
    thus "O w x \<or> O w y"..
  qed
qed

lemma strong_sum_closure:
  "\<exists>z. (P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)"
proof -
  from pair obtain z where z: "(\<forall>w. (w = x \<or> w = y) \<longrightarrow> P w z) \<and> (\<forall>w. P w z \<longrightarrow> (\<exists>v. (v = x \<or> v = y) \<and> O w v))"..
  have "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)"
  proof
    from z have allw: "\<forall>w. (w = x \<or> w = y) \<longrightarrow> P w z"..
    hence "x = x \<or> x = y \<longrightarrow> P x z"..
    moreover have "x = x \<or> x = y" using refl..
    ultimately have "P x z"..
    from allw have "y = x \<or> y = y \<longrightarrow> P y z"..
    moreover have "y = x \<or> y = y" using refl..
    ultimately have "P y z"..
    with `P x z` show "P x z \<and> P y z"..
  next
    show "\<forall>w. P w z \<longrightarrow> O w x \<or> O w y"
    proof
      fix w
      show "P w z \<longrightarrow> O w x \<or> O w y"
      proof
        assume "P w z"
        from z have "\<forall>w. P w z \<longrightarrow> (\<exists>v. (v = x \<or> v = y) \<and> O w v)"..
        hence "P w z \<longrightarrow> (\<exists>v. (v = x \<or> v = y) \<and> O w v)"..
        hence "\<exists>v. (v = x \<or> v = y) \<and> O w v" using `P w z`..
        then obtain v where v: "(v = x \<or> v = y) \<and> O w v"..
        thus "O w x \<or> O w y" by (rule or_id)
      qed
    qed
  qed
  thus ?thesis..
qed

end

sublocale GEM1 \<subseteq> GMM
proof
  fix x y \<phi>
  show "(\<exists>x. \<phi> x) \<Longrightarrow> (\<exists>z. \<forall>y. O y z \<longleftrightarrow> (\<exists>x. \<phi> x \<and> O y x))" using fusion.
qed

context GEM1
begin

lemma least_upper_bound:
  assumes sf:
    "((\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)))"
  shows lub:
      "(\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>z. (\<forall>y. F y \<longrightarrow> P y z) \<longrightarrow> P x z)"
proof
 from sf show "\<forall>y. F y \<longrightarrow> P y x"..
next
 show "(\<forall>z. (\<forall>y. F y \<longrightarrow> P y z) \<longrightarrow> P x z)"
 proof
  fix z
  show "(\<forall>y. F y \<longrightarrow> P y z) \<longrightarrow> P x z"
  proof
   assume z: "\<forall>y. F y \<longrightarrow> P y z"
   from pair obtain v where v: "(\<forall>w. (w = x \<or> w = z) \<longrightarrow> P w v) \<and> (\<forall>w. P w v \<longrightarrow> (\<exists>y. (y = x \<or> y = z) \<and> O w y))"..
   hence left: "(\<forall>w. (w = x \<or> w = z) \<longrightarrow> P w v)"..
   hence "(x = x \<or> x = z) \<longrightarrow> P x v"..
   moreover have "x = x \<or> x = z" using refl..
   ultimately have "P x v"..
   have "z = v"
   proof (rule ccontr)
    assume "z \<noteq> v"
    from left have "z = x \<or> z = z \<longrightarrow> P z v"..
    moreover have "z = x \<or> z = z" using refl..
    ultimately have "P z v"..
    hence "P z v \<and> z \<noteq> v" using `z \<noteq> v`..
    with nip_eq have "PP z v"..
    hence "\<exists>w. P w v \<and> \<not> O w z" by (rule weak_supplementation)
    then obtain w where w: "P w v \<and> \<not> O w z"..
    hence "P w v"..
    from v have right:
      "\<forall>w. P w v \<longrightarrow> (\<exists>y. (y = x \<or> y = z) \<and> O w y)"..
    hence "P w v \<longrightarrow> (\<exists>y. (y = x \<or> y = z) \<and> O w y)"..
    hence "\<exists>y. (y = x \<or> y = z) \<and> O w y" using `P w v`..
    then obtain s where s: "(s = x \<or> s = z) \<and> O w s"..
    hence "s = x \<or> s = z"..
    thus "False"
    proof
     assume "s = x"
     moreover from s have "O w s"..
     ultimately have "O w x" by (rule subst)
     with overlap_eq have "\<exists>t. P t w \<and> P t x"..
     then obtain t where t: "P t w \<and> P t x"..
     hence "P t x"..
     from sf have "(\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))"..
     hence "P t x \<longrightarrow> (\<exists>z. F z \<and> O t z)"..
     hence "\<exists>z. F z \<and> O t z" using `P t x`..
     then obtain a where a: "F a \<and> O t a"..
     hence "F a"..
     from sf have ub: "\<forall>y. F y \<longrightarrow> P y x"..
     hence "F a \<longrightarrow> P a x"..
     hence "P a x" using `F a`..
     moreover from a have "O t a"..
     ultimately have "O t x"
      by (rule overlap_monotonicity)
     from t have "P t w"..
     moreover have "O z t"
     proof -
      from z have "F a \<longrightarrow> P a z"..
      moreover from a have "F a"..
      ultimately have "P a z"..
      moreover from a have "O t a"..
      ultimately have "O t z"
       by (rule overlap_monotonicity)
      thus "O z t" by (rule overlap_symmetry)
     qed
     ultimately have "O z w"
      by (rule overlap_monotonicity)
     hence "O w z" by (rule overlap_symmetry)
     from w have "\<not> O w z"..
     thus "False" using `O w z`..
    next
     assume "s = z"
     moreover from s have "O w s"..
     ultimately have "O w z" by (rule subst)
     from w have "\<not> O w z"..
     thus "False" using `O w z`..
    qed
   qed
   thus "P x z" using `P x v` by (rule ssubst)
  qed
 qed
qed

corollary strong_fusion_intro:  "(\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)) \<Longrightarrow> (\<sigma> x. F x) = x"
proof -
  assume antecedent: "(\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))"
  with least_upper_bound have lubx:
    "(\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>z. (\<forall>y. F y \<longrightarrow> P y z) \<longrightarrow> P x z)".
  from antecedent have "\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)"..
  hence "P x x \<longrightarrow> (\<exists>z. F z \<and> O x z)"..
  hence "\<exists>z. F z \<and> O x z" using part_reflexivity..
  then obtain z where z: "F z \<and> O x z"..
  hence "F z"..
  hence "\<exists>z. F z"..
  hence "(\<sigma> x. F x) = (THE x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)))" by (rule strong_fusion_eq)
  moreover have "(THE x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))) = x"
  proof (rule the_equality)
    show "(\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))"
      using antecedent.
  next
    fix w
    assume w:
      "(\<forall>y. F y \<longrightarrow> P y w) \<and> (\<forall>y. P y w \<longrightarrow> (\<exists>z. F z \<and> O y z))"
    with least_upper_bound have lubw:
      "(\<forall>y. F y \<longrightarrow> P y w) \<and> (\<forall>z. (\<forall>y. F y \<longrightarrow> P y z) \<longrightarrow> P w z)".
    hence "(\<forall>z. (\<forall>y. F y \<longrightarrow> P y z) \<longrightarrow> P w z)"..
    hence "(\<forall>y. F y \<longrightarrow> P y x) \<longrightarrow> P w x"..
    moreover from antecedent have "\<forall>y. F y \<longrightarrow> P y x"..
    ultimately have "P w x"..
    from lubx have "(\<forall>z. (\<forall>y. F y \<longrightarrow> P y z) \<longrightarrow> P x z)"..
    hence "(\<forall>y. F y \<longrightarrow> P y w) \<longrightarrow> P x w"..
    moreover from lubw have "(\<forall>y. F y \<longrightarrow> P y w)"..
    ultimately have "P x w"..
    with `P w x` show "w = x"
      by (rule part_antisymmetry)
  qed
  ultimately show "(\<sigma> x. F x) = x" by (rule ssubst)
qed

lemma strong_fusion_character: "\<exists>x. F x \<Longrightarrow> ((\<forall>y. F y \<longrightarrow> P y (\<sigma> x. F x)) \<and> (\<forall>y. P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z)))"
proof -
  assume "\<exists>x. F x"
  hence "(\<exists>x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)))" by (rule strong_fusion)
  then obtain x where x:
    "(\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))"..
  hence "(\<sigma> x. F x) = x" by (rule strong_fusion_intro)
  thus ?thesis using x by (rule ssubst)
qed

lemma F_in: "\<exists>x. F x \<Longrightarrow> (\<forall>y. F y \<longrightarrow> P y (\<sigma> x. F x))"
proof -
  assume "\<exists>x. F x"
  hence "((\<forall>y. F y \<longrightarrow> P y (\<sigma> x. F x)) \<and> (\<forall>y. P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z)))" by (rule strong_fusion_character)
 thus "\<forall>y. F y \<longrightarrow> P y (\<sigma> x. F x)"..
qed

lemma parts_overlap_Fs:
  "\<exists>x. F x \<Longrightarrow> (\<forall>y. P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z))"
proof -
  assume "\<exists>x. F x"
  hence "((\<forall>y. F y \<longrightarrow> P y (\<sigma> x. F x)) \<and> (\<forall>y. P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z)))" by (rule strong_fusion_character)
  thus "(\<forall>y. P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z))"..
qed

lemma in_strong_fusion: "P z (\<sigma> x. z = x)"
proof -
  have "\<exists>y. z = y" using refl..
  hence "\<forall>y. z = y \<longrightarrow> P y (\<sigma> x. z = x)"
    by (rule F_in)
  hence "z = z \<longrightarrow> P z (\<sigma> x. z = x)"..
  thus "P z (\<sigma> x. z = x)" using refl..
qed

lemma strong_fusion_in: "P (\<sigma> x. z = x) z"
proof -
  have "\<exists>y. z = y" using refl..
  hence sf:
    "(\<forall>y. z = y \<longrightarrow> P y (\<sigma> x. z = x)) \<and> (\<forall>y. P y (\<sigma> x. z = x) \<longrightarrow> (\<exists>v. z = v \<and> O y v))"
    by (rule strong_fusion_character)
  with least_upper_bound have lub: "(\<forall>y. z = y \<longrightarrow> P y (\<sigma> x. z = x)) \<and> (\<forall>v. (\<forall>y. z = y \<longrightarrow> P y v) \<longrightarrow> P (\<sigma> x. z = x) v)".
  hence "(\<forall>v. (\<forall>y. z = y \<longrightarrow> P y v) \<longrightarrow> P (\<sigma> x. z = x) v)"..
  hence "(\<forall>y. z = y \<longrightarrow> P y z) \<longrightarrow> P (\<sigma> x. z = x) z"..
  moreover have "(\<forall>y. z = y \<longrightarrow> P y z)"
  proof
    fix y
    show "z = y \<longrightarrow> P y z"
    proof
      assume "z = y"
      thus "P y z" using part_reflexivity by (rule subst)
    qed
  qed
  ultimately show "P (\<sigma> x. z = x) z"..
qed

lemma strong_fusion_idempotence: "(\<sigma> x. z = x) = z"
 using strong_fusion_in in_strong_fusion by (rule part_antisymmetry)

subsection \<open> Strong Sums \<close>

lemma pair_fusion: "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y) \<longrightarrow> (\<sigma> z. z = x \<or> z = y) = z"
proof
 assume z: "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)"
  have "(\<forall>v. v = x \<or> v = y \<longrightarrow> P v z) \<and> (\<forall>v. P v z \<longrightarrow> (\<exists>z. (z = x \<or> z = y) \<and> O v z))"
 proof
  show "\<forall>v. v = x \<or> v = y \<longrightarrow> P v z"
  proof
   fix w
   from z have "P x z \<and> P y z"..
   show "w = x \<or> w = y \<longrightarrow> P w z"
   proof
    assume "w = x \<or> w = y"
    thus "P w z"
    proof
     assume "w = x"
     moreover from `P x z \<and> P y z` have "P x z"..
     ultimately show "P w z" by (rule ssubst)
    next
     assume "w = y"
     moreover from `P x z \<and> P y z` have "P y z"..
     ultimately show "P w z" by (rule ssubst)
    qed
   qed
  qed
  show "\<forall>v. P v z \<longrightarrow> (\<exists>z. (z = x \<or> z = y) \<and> O v z)"
  proof
   fix v
   show "P v z \<longrightarrow> (\<exists>z. (z = x \<or> z = y) \<and> O v z)"
   proof
    assume "P v z"
    from z have "\<forall>w. P w z \<longrightarrow> O w x \<or> O w y"..
    hence "P v z \<longrightarrow> O v x \<or> O v y"..
    hence "O v x \<or> O v y" using `P v z`..
    thus "\<exists>z. (z = x \<or> z = y) \<and> O v z"
    proof
     assume "O v x"
     have "x = x \<or> x = y" using refl..
     hence "(x = x \<or> x = y) \<and> O v x" using `O v x`..
     thus "\<exists>z. (z = x \<or> z = y) \<and> O v z"..
    next
     assume "O v y"
     have "y = x \<or> y = y" using refl..
     hence "(y = x \<or> y = y) \<and> O v y" using `O v y`..
     thus "\<exists>z. (z = x \<or> z = y) \<and> O v z"..
    qed
   qed
  qed
 qed
  thus "(\<sigma> z. z = x \<or> z = y) = z"
    by (rule strong_fusion_intro)
qed

corollary strong_sum_fusion: "x \<oplus> y = (\<sigma> z. z = x \<or> z = y)"
proof -
  have "(THE z. (P x z \<and> P y z) \<and>
    (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)) = (\<sigma> z. z = x \<or> z = y)"
  proof (rule the_equality)
    have "x = x \<or> x = y" using refl..
    hence exz: "\<exists>z. z = x \<or> z = y"..
    hence allw: "(\<forall>w. w = x \<or> w = y \<longrightarrow> P w (\<sigma> z. z = x \<or> z = y))"
      by (rule F_in)
    show "(P x (\<sigma> z. z = x \<or> z = y) \<and> P y (\<sigma> z. z = x \<or> z = y)) \<and>
      (\<forall>w. P w (\<sigma> z. z = x \<or> z = y) \<longrightarrow> O w x \<or> O w y)"
    proof
      show "(P x (\<sigma> z. z = x \<or> z = y) \<and> P y (\<sigma> z. z = x \<or> z = y))"
      proof
        from allw have "x = x \<or> x = y \<longrightarrow> P x (\<sigma> z. z = x \<or> z = y)"..
        thus "P x (\<sigma> z. z = x \<or> z = y)"
          using `x = x \<or> x = y`..
      next
        from allw have "y = x \<or> y = y \<longrightarrow> P y (\<sigma> z. z = x \<or> z = y)"..
        moreover have "y = x \<or> y = y"
          using refl..
        ultimately show "P y (\<sigma> z. z = x \<or> z = y)"..
      qed
    next
      show "\<forall>w. P w (\<sigma> z. z = x \<or> z = y) \<longrightarrow> O w x \<or> O w y"
      proof
        fix w
        show "P w (\<sigma> z. z = x \<or> z = y) \<longrightarrow> O w x \<or> O w y"
        proof
          have "\<forall>v. P v (\<sigma> z. z = x \<or> z = y) \<longrightarrow> (\<exists>z. (z = x \<or> z = y) \<and> O v z)" using exz by (rule parts_overlap_Fs)
          hence "P w (\<sigma> z. z = x \<or> z = y) \<longrightarrow> (\<exists>z. (z = x \<or> z = y) \<and> O w z)"..
          moreover assume "P w (\<sigma> z. z = x \<or> z = y)"
          ultimately have "(\<exists>z. (z = x \<or> z = y) \<and> O w z)"..
          then obtain z where z: "(z = x \<or> z = y) \<and> O w z"..
          thus "O w x \<or> O w y" by (rule or_id)
        qed
      qed
    qed
  next
    fix z
    assume z: "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)"
    with pair_fusion have "(\<sigma> z. z = x \<or> z = y) = z"..
    thus "z = (\<sigma> z. z = x \<or> z = y)"..
  qed
  with strong_sum_eq show "x \<oplus> y = (\<sigma> z. z = x \<or> z = y)"
    by (rule ssubst)
qed

corollary strong_sum_intro:
  "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y) \<longrightarrow> x \<oplus> y = z"
proof
  assume z: "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)"
  with pair_fusion have "(\<sigma> z. z = x \<or> z = y) = z"..
  with strong_sum_fusion show "(x \<oplus> y) = z"
    by (rule ssubst)
qed

corollary strong_sum_character: "(P x (x \<oplus> y) \<and> P y (x \<oplus> y)) \<and> (\<forall>w. P w (x \<oplus> y) \<longrightarrow> O w x \<or> O w y)"
proof -
  from strong_sum_closure obtain z where z:
    "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)"..
 with strong_sum_intro have "x \<oplus> y = z"..
 thus ?thesis using z by (rule ssubst)
qed

corollary summands_in: "(P x (x \<oplus> y) \<and> P y (x \<oplus> y))"
  using strong_sum_character..

corollary first_summand_in: "P x (x \<oplus> y)" using summands_in..

corollary second_summand_in: "P y (x \<oplus> y)" using summands_in..

corollary sum_part_overlap: "(\<forall>w. P w (x \<oplus> y) \<longrightarrow> O w x \<or> O w y)" using strong_sum_character..

lemma strong_sum_absorption: "y = (x \<oplus> y) \<Longrightarrow> P x y"
proof -
 assume "y = (x \<oplus> y)"
 thus "P x y" using first_summand_in by (rule ssubst)
qed

theorem strong_supplementation: "\<not> P x y \<Longrightarrow> (\<exists>z. P z x \<and> \<not> O z y)"
proof -
 assume "\<not> P x y"
 have "\<not> (\<forall>z. P z x \<longrightarrow> O z y)"
 proof
  assume z: "\<forall>z. P z x \<longrightarrow> O z y"
  have "(\<forall>v. y = v \<longrightarrow> P v (x \<oplus> y)) \<and>
    (\<forall>v. P v (x \<oplus> y) \<longrightarrow> (\<exists>z. y = z \<and> O v z))"
  proof
   show "\<forall>v. y = v \<longrightarrow> P v (x \<oplus> y)"
   proof
    fix v
    show "y = v \<longrightarrow> P v (x \<oplus> y)"
    proof
     assume "y = v"
     thus "P v (x \<oplus> y)"
       using second_summand_in by (rule subst)
    qed
   qed
   show "\<forall>v. P v (x \<oplus> y) \<longrightarrow> (\<exists>z. y = z \<and> O v z)"
   proof
    fix v
    show "P v (x \<oplus> y) \<longrightarrow> (\<exists>z. y = z \<and> O v z)"
    proof
     assume "P v (x \<oplus> y)"
     moreover from sum_part_overlap have
       "P v (x \<oplus> y) \<longrightarrow> O v x \<or> O v y"..
     ultimately have "O v x \<or> O v y" by (rule rev_mp)
     hence "O v y"
     proof
      assume "O v x"
      with overlap_eq have "\<exists>w. P w v \<and> P w x"..
      then obtain w where w: "P w v \<and> P w x"..
      from z have "P w x \<longrightarrow> O w y"..
      moreover from w have "P w x"..
      ultimately have "O w y"..
      with overlap_eq have "\<exists>t. P t w \<and> P t y"..
      then obtain t where t: "P t w \<and> P t y"..
      hence "P t w"..
      moreover from w have "P w v"..
      ultimately have "P t v"
        by (rule part_transitivity)
      moreover from t have "P t y"..
      ultimately show "O v y"
        by (rule overlap_intro)
     next
      assume "O v y"
      thus "O v y".
     qed
     with refl have "y = y \<and> O v y"..
     thus "\<exists>z. y = z \<and> O v z"..
    qed
   qed
  qed
  hence  "(\<sigma> z. y = z) = (x \<oplus> y)" by (rule strong_fusion_intro)
  with strong_fusion_idempotence have "y = x \<oplus> y" by (rule subst)
  hence "P x y" by (rule strong_sum_absorption)
  with `\<not> P x y` show "False"..
 qed
 thus "\<exists>z. P z x \<and> \<not> O z y" by simp
qed

lemma sum_character: "\<forall>v. O v (x \<oplus> y) \<longleftrightarrow> (O v x \<or> O v y)"
proof
  fix v
  show "O v (x \<oplus> y) \<longleftrightarrow> (O v x \<or> O v y)"
  proof
    assume "O v (x \<oplus> y)"
    with overlap_eq have "\<exists>w. P w v \<and> P w (x \<oplus> y)"..
    then obtain w where w: "P w v \<and> P w (x \<oplus> y)"..
    hence "P w v"..
    have "P w (x \<oplus> y) \<longrightarrow> O w x \<or> O w y" using sum_part_overlap..
    moreover from w have "P w (x \<oplus> y)"..
    ultimately have "O w x \<or> O w y"..
    thus "O v x \<or> O v y"
    proof
      assume "O w x"
      hence "O x w"
        by (rule overlap_symmetry)
      with `P w v` have "O x v"
        by (rule overlap_monotonicity)
      hence "O v x"
        by (rule overlap_symmetry)
      thus "O v x \<or> O v y"..
    next
      assume "O w y"
      hence "O y w"
        by (rule overlap_symmetry)
      with `P w v` have "O y v"
        by (rule overlap_monotonicity)
      hence "O v y" by (rule overlap_symmetry)
      thus "O v x \<or> O v y"..
    qed
  next
    assume "O v x \<or> O v y"
    thus "O v (x \<oplus> y)"
    proof
      assume "O v x"
      with overlap_eq have "\<exists>w. P w v \<and> P w x"..
      then obtain w where w: "P w v \<and> P w x"..
      hence "P w v"..
      moreover from w have "P w x"..
      hence "P w (x \<oplus> y)" using first_summand_in
        by (rule part_transitivity)
      ultimately show "O v (x \<oplus> y)"
        by (rule overlap_intro)
    next
      assume "O v y"
      with overlap_eq have "\<exists>w. P w v \<and> P w y"..
      then obtain w where w: "P w v \<and> P w y"..
      hence "P w v"..
      moreover from w have "P w y"..
      hence "P w (x \<oplus> y)" using second_summand_in
        by (rule part_transitivity)
      ultimately show "O v (x \<oplus> y)"
        by (rule overlap_intro)
    qed
  qed
qed

lemma sum_eq: "x \<oplus> y = (THE z. \<forall>v. O v z = (O v x \<or> O v y))"
proof -
  have "(THE z. \<forall>v. O v z \<longleftrightarrow> (O v x \<or> O v y)) = x \<oplus> y"
  proof (rule the_equality)
    show "\<forall>v. O v (x \<oplus> y) \<longleftrightarrow> (O v x \<or> O v y)" using sum_character.
  next
    fix z
    assume z: "\<forall>v. O v z \<longleftrightarrow> (O v x \<or> O v y)"
    have "(P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y)"
    proof
      show "P x z \<and> P y z"
      proof
        show "P x z"
        proof (rule ccontr)
          assume "\<not> P x z"
          hence "\<exists>v. P v x \<and> \<not> O v z"
            by (rule strong_supplementation)
          then obtain v where v: "P v x \<and> \<not> O v z"..
          hence "\<not> O v z"..
          from z have "O v z \<longleftrightarrow> (O v x \<or> O v y)"..
          moreover from v have "P v x"..
          hence "O v x" by (rule part_implies_overlap)
          hence "O v x \<or> O v y"..
          ultimately have "O v z"..
          with `\<not> O v z` show "False"..
        qed
      next
        show "P y z"
        proof (rule ccontr)
          assume "\<not> P y z"
          hence "\<exists>v. P v y \<and> \<not> O v z"
            by (rule strong_supplementation)
          then obtain v where v: "P v y \<and> \<not> O v z"..
          hence "\<not> O v z"..
          from z have "O v z \<longleftrightarrow> (O v x \<or> O v y)"..
          moreover from v have "P v y"..
          hence "O v y" by (rule part_implies_overlap)
          hence "O v x \<or> O v y"..
          ultimately have "O v z"..
          with `\<not> O v z` show "False"..
        qed
      qed
      show "\<forall>w. P w z \<longrightarrow> (O w x \<or> O w y)"
      proof
        fix w
        show "P w z \<longrightarrow> (O w x \<or> O w y)"
        proof
          from z have "O w z \<longleftrightarrow> O w x \<or> O w y"..
          moreover assume "P w z"
          hence "O w z" by (rule part_implies_overlap)
          ultimately show "O w x \<or> O w y"..
        qed
      qed
    qed
    with strong_sum_intro have "x \<oplus> y = z"..
    thus "z = x \<oplus> y"..
  qed
  thus ?thesis..
qed

theorem fusion_eq: "\<exists>x. F x \<Longrightarrow>
  (\<sigma> x. F x) = (THE x. \<forall>y. O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z))"
proof -
  assume "\<exists>x. F x"
  hence bla: "\<forall>y. P y (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O y z)"
    by (rule parts_overlap_Fs)
  have "(THE x. \<forall>y. O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z)) = (\<sigma> x. F x)"
  proof (rule the_equality)
    show "\<forall>y. O y (\<sigma> x. F x) \<longleftrightarrow> (\<exists>z. F z \<and> O y z)"
    proof
      fix y
      show "O y (\<sigma> x. F x) \<longleftrightarrow> (\<exists>z. F z \<and> O y z)"
      proof
        assume "O y (\<sigma> x. F x)"
        with overlap_eq have "\<exists>v. P v y \<and> P v (\<sigma> x. F x)"..
        then obtain v where v: "P v y \<and> P v (\<sigma> x. F x)"..
        hence "P v y"..
        from bla have "P v (\<sigma> x. F x) \<longrightarrow> (\<exists>z. F z \<and> O v z)"..
        moreover from v have "P v (\<sigma> x. F x)"..
        ultimately have "(\<exists>z. F z \<and> O v z)"..
        then obtain z where z: "F z \<and> O v z"..
        hence "F z"..
        moreover from z have "O v z"..
        hence "O z v" by (rule overlap_symmetry)
        with `P v y` have "O z y" by (rule overlap_monotonicity)
        hence "O y z" by (rule overlap_symmetry)
        ultimately have "F z \<and> O y z"..
        thus "(\<exists>z. F z \<and> O y z)"..
      next
        assume "\<exists>z. F z \<and> O y z"
        then obtain z where z: "F z \<and> O y z"..
        from`\<exists>x. F x` have "(\<forall>y. F y \<longrightarrow> P y (\<sigma> x. F x))"
          by (rule F_in)
        hence "F z \<longrightarrow>  P z (\<sigma> x. F x)"..
        moreover from z have "F z"..
        ultimately have "P z (\<sigma> x. F x)"..
        moreover from z have "O y z"..
        ultimately show "O y (\<sigma> x. F x)"
          by (rule overlap_monotonicity)
      qed
    qed
  next
    fix x
    assume x: "\<forall>y. O y x \<longleftrightarrow> (\<exists>v. F v \<and> O y v)"
    have "(\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z))"
    proof
      show "\<forall>y. F y \<longrightarrow> P y x"
      proof
        fix y
        show "F y \<longrightarrow> P y x"
        proof
          assume "F y"
          show "P y x"
          proof (rule ccontr)
            assume "\<not> P y x"
            hence "\<exists>z. P z y \<and> \<not> O z x"
              by (rule strong_supplementation)
            then obtain z where z: "P z y \<and> \<not> O z x"..
            hence "\<not> O z x"..
            from x have "O z x \<longleftrightarrow> (\<exists>v. F v \<and> O z v)"..
            moreover from z have "P z y"..
            hence "O z y" by (rule part_implies_overlap)
            with `F y` have "F y \<and> O z y"..
            hence "\<exists>y. F y \<and> O z y"..
            ultimately have "O z x"..
            with `\<not> O z x` show "False"..
          qed
        qed
      qed
      show "\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)"
      proof
        fix y
        show "P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)"
        proof
          from x have "O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z)"..
          moreover assume "P y x"
          hence "O y x" by (rule part_implies_overlap)
          ultimately show "\<exists>z. F z \<and> O y z"..
        qed
      qed
    qed
    hence "(\<sigma> x. F x) = x"
      by (rule strong_fusion_intro)
    thus "x = (\<sigma> x. F x)"..
  qed
  thus "(\<sigma> x. F x) = (THE x. \<forall>y. O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z))"..
qed

end

sublocale GEM1 \<subseteq> GEM
proof
  fix x y F
  show "\<not> P x y \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y"
    using strong_supplementation.
  show "x \<oplus> y = (THE z. \<forall>v. O v z \<longleftrightarrow> (O v x \<or> O v y))"
    using sum_eq.
  show "x \<otimes> y = (THE z. \<forall>v. P v z \<longleftrightarrow> P v x \<and> P v y)"
    using product_eq.
  show "x \<ominus> y = (THE z. \<forall>w. P w z = (P w x \<and> \<not> O w y))"
    using difference_eq.
  show "\<midarrow> x = (THE z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
    using complement_eq.
  show "u = (THE x. \<forall>y. P y x)"
    using universe_eq.
  show "\<exists>x. F x \<Longrightarrow> (\<sigma> x. F x) = (THE x. \<forall>y. O y x \<longleftrightarrow> (\<exists>z. F z \<and> O y z))" using fusion_eq.
  show "(\<pi> x. F x) = (\<sigma> x. \<forall>y. F y \<longrightarrow> P x y)"
    using general_product_eq.
qed

sublocale GEM \<subseteq> GEM1
proof
  fix x y F
  show "\<exists>x. F x \<Longrightarrow> (\<exists>x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)))" using strong_fusion.
  show "\<exists>x. F x \<Longrightarrow> (\<sigma> x. F x) = (THE x. (\<forall>y. F y \<longrightarrow> P y x) \<and> (\<forall>y. P y x \<longrightarrow> (\<exists>z. F z \<and> O y z)))" using strong_fusion_eq.
  show "(\<pi> x. F x) = (\<sigma> x. \<forall>y. F y \<longrightarrow> P x y)" using general_product_eq.
  show "x \<oplus> y = (THE z. (P x z \<and> P y z) \<and> (\<forall>w. P w z \<longrightarrow> O w x \<or> O w y))" using strong_sum_eq.
  show "x \<otimes> y = (THE z. \<forall>v. P v z \<longleftrightarrow> P v x \<and> P v y)"
    using product_eq.
  show "x \<ominus> y = (THE z. \<forall>w. P w z = (P w x \<and> \<not> O w y))"
    using difference_eq.
  show "\<midarrow> x = (THE z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)" using complement_eq.
  show "u = (THE x. \<forall>y. P y x)" using universe_eq.
qed

(*<*) end (*>*)


section \<open>Abstract Model-Checker\<close>
theory CAVA_Abstract
imports
  CAVA_Base.CAVA_Base
  CAVA_Automata.Automata
  LTL.LTL
begin
text \<open>
  This theory defines the abstract version of the cava model checker,
  as well as a generic implementation.
\<close>

subsection \<open>Specification of an LTL Model-Checker\<close>
text \<open>
  Abstractly, an LTL model-checker consists of three components:
  \begin{enumerate}
    \item A conversion of LTL-formula to Indexed Generalized Buchi Automata
      (IGBA) over sets of atomic propositions.
    \item An intersection construction, which takes a system and an IGBA, and
      creates an Indexed Generalized Buchi Graph (IGBG) and a projection
      function to project runs of the IGBG back to runs of the system.
    \item An emptiness check for IGBGs.
  \end{enumerate}
\<close>

text \<open>Given an LTL formula, the LTL to Buchi conversion
  returns a Generalized Buchi Automaton that accepts the same language.\<close>
definition ltl_to_gba_spec
  :: "'prop ltlc \<Rightarrow> ('q, 'prop set, _) igba_rec_scheme nres"
  \<comment> \<open>Conversion of LTL formula to generalized buchi automaton\<close>
  where "ltl_to_gba_spec \<phi> \<equiv> SPEC (\<lambda>gba.
    igba.lang gba = language_ltlc \<phi> \<and> igba gba \<and> finite ((g_E gba)\<^sup>* `` g_V0 gba))"

definition inter_spec
  :: "('s,'prop set,_) sa_rec_scheme
  \<Rightarrow> ('q,'prop set,_) igba_rec_scheme
  \<Rightarrow> (('prod_state,_) igb_graph_rec_scheme \<times> ('prod_state \<Rightarrow> 's)) nres"
  \<comment> \<open>Intersection of system and IGBA\<close>
  where "\<And>sys ba. inter_spec sys ba \<equiv> do {
    ASSERT (sa sys);
    ASSERT (finite ((g_E sys)\<^sup>* `` g_V0 sys));
    ASSERT (igba ba);
    ASSERT (finite ((g_E ba)\<^sup>* `` g_V0 ba));
    SPEC (\<lambda>(G,project). igb_graph G \<and> finite ((g_E G)\<^sup>* `` g_V0 G) \<and> (\<forall>r.
      (\<exists>r'. igb_graph.is_acc_run G r' \<and> r = project o r')
        \<longleftrightarrow> (graph_defs.is_run sys r \<and> sa_L sys o r \<in> igba.lang ba)))
  }"

definition find_ce_spec
  :: "('q,_) igb_graph_rec_scheme \<Rightarrow> 'q word option option nres"
  \<comment> \<open>Check Generalized Buchi graph for emptiness, with optional counterexample\<close>
  where "find_ce_spec G \<equiv> do {
    ASSERT (igb_graph G);
    ASSERT (finite ((g_E G)\<^sup>* `` g_V0 G));
    SPEC (\<lambda>res. case res of
      None \<Rightarrow> (\<forall>r. \<not>igb_graph.is_acc_run G r)
    | Some None \<Rightarrow> (\<exists>r. igb_graph.is_acc_run G r)
    | Some (Some r) \<Rightarrow> igb_graph.is_acc_run G r
    )}"

text \<open>
  Using the specifications from above, we can specify the essence
  of the model-checking algorithm: Convert the LTL-formula to a GBA,
  make an intersection with the system and check the result for emptiness.
\<close>

definition abs_model_check
  :: "'ba_state itself \<Rightarrow> 'ba_more itself
  \<Rightarrow> 'prod_state itself \<Rightarrow> 'prod_more itself
  \<Rightarrow> ('s,'prop set,_) sa_rec_scheme \<Rightarrow> 'prop ltlc
  \<Rightarrow> 's word option option nres"
  where
  "abs_model_check _ _ _ _ sys \<phi> \<equiv> do {
    gba :: ('ba_state,_,'ba_more) igba_rec_scheme
      \<leftarrow> ltl_to_gba_spec (Not_ltlc \<phi>);
    ASSERT (igba gba);
    ASSERT (sa sys);
    (Gprod::('prod_state,'prod_more)igb_graph_rec_scheme, map_state)
      \<leftarrow> inter_spec sys gba;
    ASSERT (igb_graph Gprod);
    ce \<leftarrow> find_ce_spec Gprod;

    case ce of
      None \<Rightarrow> RETURN None
    | Some None \<Rightarrow> RETURN (Some None)
    | Some (Some r) \<Rightarrow> RETURN (Some (Some (map_state o r)))
  }"

text \<open>
  The main correctness theorem states that our abstract model checker
  really checks whether the system satisfies the formula, and a
  correct counterexample is returned (if any).
  Note that, if the model does not satisfy the formula,
  returning a counterexample is optional.
\<close>
theorem abs_model_check_correct:
  "abs_model_check T1 T2 T3 T4 sys \<phi> \<le> do {
    ASSERT (sa sys);
    ASSERT (finite ((g_E sys)\<^sup>* `` g_V0 sys));
    SPEC (\<lambda>res. case res of
      None \<Rightarrow> sa.lang sys \<subseteq> language_ltlc \<phi>
    | Some None \<Rightarrow> \<not> sa.lang sys \<subseteq> language_ltlc \<phi>
    | Some (Some r) \<Rightarrow> graph_defs.is_run sys r \<and> sa_L sys \<circ> r \<notin> language_ltlc \<phi>)
  }"
  unfolding abs_model_check_def ltl_to_gba_spec_def inter_spec_def
    find_ce_spec_def
  apply (refine_rcg refine_vcg ASSERT_leI le_ASSERTI)
  apply (auto simp: sa.lang_def
    sa.accept_def[THEN meta_eq_to_obj_eq, THEN ext[of "sa.accept sys"] ])
    (* TODO: We really need an extended abs_def attribute, that digests
      conditional definitions! *)
  done

subsection \<open>Generic Implementation\<close>
text \<open>
  In this section, we define a generic implementation of an LTL model checker,
  that is parameterized with implementations of its components.
\<close>

abbreviation "ltl_rel \<equiv> Id :: ('a ltlc \<times> _) set"

locale impl_model_checker =
  \<comment> \<open>Assembly of a generic model-checker\<close>
  fixes sa_rel :: "('sai \<times> ('s,'prop set,'sa_more) sa_rec_scheme) set"
  fixes igba_rel :: "('igbai \<times> ('q, 'prop set, 'igba_more) igba_rec_scheme) set"
  fixes igbg_rel :: "('igbgi \<times> ('sq, 'igbg_more) igb_graph_rec_scheme) set"
  fixes ce_rel :: "('cei \<times> 'sq word) set"
  fixes mce_rel :: "('mcei \<times> 's word) set"

  fixes ltl_to_gba_impl :: "'cfg_l2b \<Rightarrow> 'prop ltlc \<Rightarrow> 'igbai"
  fixes inter_impl :: "'cfg_int \<Rightarrow> 'sai \<Rightarrow> 'igbai \<Rightarrow> 'igbgi \<times> ('sq \<Rightarrow> 's)"
  fixes find_ce_impl :: "'cfg_ce \<Rightarrow> 'igbgi \<Rightarrow> 'cei option option"
  fixes map_run_impl :: "('sq \<Rightarrow> 's) \<Rightarrow> 'cei \<Rightarrow> 'mcei"

  assumes [relator_props, simp, intro!]: "single_valued mce_rel"

  assumes ltl_to_gba_refine:
    "\<And>cfg. (ltl_to_gba_impl cfg,ltl_to_gba_spec)
      \<in> ltl_rel \<rightarrow> \<langle>igba_rel\<rangle>plain_nres_rel"
  assumes inter_refine:
    "\<And>cfg. (inter_impl cfg,inter_spec)
      \<in> sa_rel \<rightarrow> igba_rel \<rightarrow> \<langle>igbg_rel \<times>\<^sub>r (Id \<rightarrow> Id)\<rangle>plain_nres_rel"
  assumes find_ce_refine:
    "\<And>cfg. (find_ce_impl cfg,find_ce_spec)
      \<in> igbg_rel \<rightarrow> \<langle>\<langle>\<langle>ce_rel\<rangle>option_rel\<rangle>option_rel\<rangle>plain_nres_rel"

  assumes map_run_refine: "(map_run_impl,(o)) \<in> (Id \<rightarrow> Id) \<rightarrow> ce_rel \<rightarrow> mce_rel"

begin

  fun cfg_l2b where "cfg_l2b (c1,c2,c3) = c1"
  fun cfg_int where "cfg_int (c1,c2,c3) = c2"
  fun cfg_ce where "cfg_ce (c1,c2,c3) = c3"

  definition impl_model_check
    :: "('cfg_l2b\<times>'cfg_int\<times>'cfg_ce)
      \<Rightarrow> 'sai \<Rightarrow> 'prop ltlc \<Rightarrow> 'mcei option option"
    where
    "impl_model_check cfg sys \<phi> \<equiv> let
      ba = ltl_to_gba_impl (cfg_l2b cfg) (Not_ltlc \<phi>);
      (G,map_q) = inter_impl (cfg_int cfg) sys ba;
      ce = find_ce_impl (cfg_ce cfg) G
    in
      case ce of
        None \<Rightarrow> None
      | Some None \<Rightarrow> Some None
      | Some (Some ce) \<Rightarrow> Some (Some (map_run_impl map_q ce))"

  lemma impl_model_check_refine:
    "(impl_model_check cfg,abs_model_check
        TYPE('q) TYPE('igba_more) TYPE('sq) TYPE('igbg_more))
      \<in> sa_rel \<rightarrow> ltl_rel \<rightarrow> \<langle>\<langle>\<langle>mce_rel\<rangle>option_rel\<rangle>option_rel\<rangle>plain_nres_rel"
    apply (intro fun_relI plain_nres_relI)
    unfolding abs_model_check_def impl_model_check_def

    apply (simp only: let_to_bind_conv pull_out_let_conv
      pull_out_RETURN_case_option)

    apply (refine_rcg
      ltl_to_gba_refine[param_fo, THEN plain_nres_relD]
      rel_arg_cong[where f="Not_ltlc"]
      inter_refine[param_fo, THEN plain_nres_relD]
      find_ce_refine[param_fo, THEN plain_nres_relD]
    )

    apply (simp_all split: option.split)
    apply (auto elim: option_relE)
    apply (parametricity add: map_run_refine)
    apply simp
    done

  theorem impl_model_check_correct:
    assumes R: "(sysi,sys)\<in>sa_rel"
    assumes [simp]: "sa sys" "finite ((g_E sys)\<^sup>* `` g_V0 sys)"
    shows "case impl_model_check cfg sysi \<phi> of
      None
        \<Rightarrow> sa.lang sys \<subseteq> language_ltlc \<phi>
    | Some None
        \<Rightarrow> \<not> sa.lang sys \<subseteq> language_ltlc \<phi>
    | Some (Some ri)
        \<Rightarrow> (\<exists>r. (ri,r)\<in>mce_rel
           \<and> graph_defs.is_run sys r \<and> sa_L sys o r \<notin> language_ltlc \<phi>)"
  proof -
    note impl_model_check_refine[
      where cfg=cfg,
      param_fo,
      THEN plain_nres_relD,
      OF R IdI[of \<phi>]]
    also note abs_model_check_correct
    finally show ?thesis
      apply (simp split: option.split)
      apply (simp add: refine_pw_simps pw_le_iff)
      apply (auto elim!: option_relE) []
      done
  qed

  theorem impl_model_check_correct_no_ce:
    assumes "(sysi,sys)\<in>sa_rel"
    assumes SA: "sa sys" "finite ((g_E sys)\<^sup>* `` g_V0 sys)"
    shows "impl_model_check cfg sysi \<phi> = None
    \<longleftrightarrow> sa.lang sys \<subseteq> language_ltlc \<phi>"
    using impl_model_check_correct[where cfg=cfg, OF assms, of \<phi>]
    by (auto
      split: option.splits
      simp: sa.lang_def[OF SA(1)] sa.accept_def[OF SA(1), abs_def])

end

end