(*  Title:      Additional Facts about Subgroups and Normal Subgroups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory SubgroupsAndNormalSubgroups
  imports
  Secondary_Sylow.SndSylow
  SndIsomorphismGrp
  "HOL-Algebra.Coset"
begin

section \<open>Preliminary lemmas\<close>

text \<open>A group of order 1 is always the trivial group.\<close>

lemma (in group) order_one_triv_iff:
  shows "(order G = 1) = (carrier G = {\<one>})"
proof
  assume order:"order G = 1"
  then obtain x where x:"carrier G = {x}" unfolding order_def by (auto simp add: card_Suc_eq)
  hence "\<one> = x" using one_closed by auto
  with x show "carrier G = {\<one>}" by simp
next
  assume "carrier G = {\<one>}"
  thus "order G = 1" unfolding order_def by auto
qed

lemma (in group) finite_pos_order:
  assumes finite:"finite (carrier G)"
  shows "0 < order G"
proof -
  from one_closed finite show ?thesis unfolding order_def by (metis card_gt_0_iff subgroup_nonempty subgroup_self)
qed

lemma iso_order_closed:
  assumes "\<phi> \<in> iso G H"
  shows "order G = order H"
using assms
unfolding order_def iso_def by (metis (no_types) bij_betw_same_card mem_Collect_eq)

section \<open>More Facts about Subgroups\<close>

lemma (in subgroup) subgroup_of_restricted_group:
  assumes "subgroup U (G\<lparr> carrier := H\<rparr>)"
  shows "U \<subseteq> H"
using assms subgroup.subset by force

lemma (in subgroup) subgroup_of_subgroup:
  assumes "group G"
  assumes "subgroup U (G\<lparr> carrier := H\<rparr>)"
  shows "subgroup U G"
proof
  from assms(2) have "U \<subseteq> H" by (rule subgroup_of_restricted_group)
  thus "U \<subseteq> carrier G" by (auto simp:subset)
next
  fix x y
  have a:"x \<otimes> y = x \<otimes>\<^bsub>G\<lparr> carrier := H\<rparr>\<^esub> y" by simp
  assume "x \<in> U" "y \<in> U"
  with assms a show " x \<otimes> y \<in> U" by (metis subgroup.m_closed)
next
  have "\<one>\<^bsub>G\<lparr> carrier := H\<rparr>\<^esub> = \<one>" by simp
  with assms show "\<one> \<in> U" by (metis subgroup.one_closed)
next
  have "subgroup H G"..
  fix x
  assume "x \<in> U"
  with assms(2) have "inv\<^bsub>G\<lparr> carrier := H\<rparr>\<^esub> x \<in> U" by (rule subgroup.m_inv_closed)
  moreover from assms \<open>x \<in> U\<close> have "x \<in> H" by (metis in_mono subgroup_of_restricted_group)
  with assms(1) \<open>subgroup H G\<close> have "inv\<^bsub>G\<lparr> carrier := H\<rparr>\<^esub> x = inv x" by (rule group.m_inv_consistent)
  ultimately show "inv x \<in> U" by simp
qed

text \<open>Being a subgroup is preserved by surjective homomorphisms\<close>

lemma (in subgroup) surj_hom_subgroup:
  assumes \<phi>:"group_hom G F \<phi>"
  assumes \<phi>surj:"\<phi> ` (carrier G) = carrier F"
  shows "subgroup (\<phi> ` H) F"
proof
  from \<phi>surj show img_subset:"\<phi> ` H \<subseteq> carrier F" unfolding iso_def bij_betw_def by auto
next
  fix f f'
  assume h:"f \<in> \<phi> ` H" and h':"f' \<in> \<phi> ` H"
  with \<phi>surj obtain g g' where g:"g \<in> H" "f = \<phi> g" and g':"g' \<in> H" "f' = \<phi> g'" by auto
  hence "g \<otimes>\<^bsub>G\<^esub> g' \<in> H" by (metis m_closed)
  hence "\<phi> (g \<otimes>\<^bsub>G\<^esub> g') \<in> \<phi> ` H" by simp
  with g g' \<phi> show "f \<otimes>\<^bsub>F\<^esub> f' \<in> \<phi> ` H"  using group_hom.hom_mult by fastforce
next
  have "\<phi> \<one> \<in> \<phi> ` H" by auto
  with \<phi> show  "\<one>\<^bsub>F\<^esub> \<in> \<phi> ` H" by (metis group_hom.hom_one)
next
  fix f
  assume f:"f \<in> \<phi> ` H"
  then obtain g where g:"g \<in> H" "f = \<phi> g" by auto
  hence "inv g \<in> H" by auto
  hence "\<phi> (inv g) \<in> \<phi> ` H" by auto
  with \<phi> g subset show "inv\<^bsub>F\<^esub> f \<in> \<phi> ` H" using group_hom.hom_inv by fastforce
qed

text \<open>... and thus of course by isomorphisms of groups.\<close>

lemma iso_subgroup:
  assumes groups:"group G" "group F"
  assumes HG:"subgroup H G"
  assumes \<phi>:"\<phi> \<in> iso G F"
  shows "subgroup (\<phi> ` H) F"
proof -
  from groups \<phi> have "group_hom G F \<phi>" unfolding group_hom_def group_hom_axioms_def iso_def by auto
  moreover from \<phi> have "\<phi> ` (carrier G) = carrier F" unfolding iso_def bij_betw_def by simp
  moreover note HG
  ultimately show ?thesis by (metis subgroup.surj_hom_subgroup)
qed

text \<open>An isomorphism restricts to an isomorphism of subgroups.\<close>

lemma iso_restrict:
  assumes groups:"group G" "group F"
  assumes HG:"subgroup H G"
  assumes \<phi>:"\<phi> \<in> iso G F"
  shows "(restrict \<phi> H) \<in> iso (G\<lparr>carrier := H\<rparr>) (F\<lparr>carrier := \<phi> ` H\<rparr>)"
unfolding iso_def hom_def bij_betw_def inj_on_def
proof auto
  fix g h
  assume "g \<in> H" "h \<in> H"
  hence "g \<in> carrier G" "h \<in> carrier G" by (metis HG subgroup.mem_carrier)+
  thus "\<phi> (g \<otimes>\<^bsub>G\<^esub> h) = \<phi> g \<otimes>\<^bsub>F\<^esub> \<phi> h" using \<phi> unfolding iso_def hom_def by auto
next
  fix g h
  assume "g \<in> H" "h \<in> H" "g \<otimes>\<^bsub>G\<^esub> h \<notin> H"
  hence "False" using HG unfolding subgroup_def by auto
  thus "undefined = \<phi> g \<otimes>\<^bsub>F\<^esub> \<phi> h" by auto
next
  fix g h
  assume g:"g \<in> H" and h:"h \<in> H" and eq:"\<phi> g = \<phi> h"
  hence "g \<in> carrier G" "h \<in> carrier G" by (metis HG subgroup.mem_carrier)+
  with eq show "g = h" using \<phi> unfolding iso_def bij_betw_def inj_on_def by auto
qed

text \<open>The intersection of two subgroups is, again, a subgroup\<close>

lemma (in group) subgroup_intersect:
  assumes "subgroup H G"
  assumes "subgroup H' G"
  shows "subgroup (H \<inter> H') G"
using assms unfolding subgroup_def by auto

section \<open>Facts about Normal Subgroups\<close>

lemma (in normal) is_normal:
  shows "H \<lhd> G"
by (metis coset_eq is_subgroup normalI)

text \<open>Being a normal subgroup is preserved by surjective homomorphisms.\<close>

lemma (in normal) surj_hom_normal_subgroup:
  assumes \<phi>:"group_hom G F \<phi>"
  assumes \<phi>surj:"\<phi> ` (carrier G) = carrier F"
  shows "(\<phi> ` H) \<lhd> F"
proof (rule group.normalI)
  from \<phi> show "group F" unfolding group_hom_def group_hom_axioms_def by simp
next
  from \<phi> \<phi>surj show "subgroup (\<phi> ` H) F" by (rule surj_hom_subgroup)
next
  show "\<forall>x\<in>carrier F. \<phi> ` H #>\<^bsub>F\<^esub> x = x <#\<^bsub>F\<^esub> \<phi> ` H"
  proof
    fix f
    assume f:"f \<in> carrier F"
    with \<phi>surj obtain g where g:"g \<in> carrier G" "f = \<phi> g" by auto
    hence "\<phi> ` H #>\<^bsub>F\<^esub> f = \<phi> ` H #>\<^bsub>F\<^esub> \<phi> g" by simp
    also have "... = (\<lambda>x. (\<phi> x) \<otimes>\<^bsub>F\<^esub> (\<phi> g)) ` H" unfolding r_coset_def image_def by auto
    also have "... = (\<lambda>x. \<phi> (x \<otimes> g)) ` H" using subset g \<phi> group_hom.hom_mult unfolding image_def by fastforce
    also have "... = \<phi> ` (H #> g)" using \<phi> unfolding r_coset_def by auto
    also have "... = \<phi> ` (g <# H)" by (metis coset_eq g(1))
    also have "... = (\<lambda>x. \<phi> (g \<otimes> x)) ` H" using \<phi> unfolding l_coset_def by auto
    also have "... = (\<lambda>x. (\<phi> g) \<otimes>\<^bsub>F\<^esub> (\<phi> x)) ` H" using subset g \<phi> group_hom.hom_mult by fastforce
    also have "... = \<phi> g <#\<^bsub>F\<^esub> \<phi> ` H" unfolding l_coset_def image_def by auto
    also have "... = f <#\<^bsub>F\<^esub> \<phi> ` H" using g by simp
    finally show "\<phi> ` H #>\<^bsub>F\<^esub> f = f <#\<^bsub>F\<^esub> \<phi> ` H".
  qed
qed

text \<open>Being a normal subgroup is preserved by group isomorphisms.\<close>

lemma iso_normal_subgroup:
  assumes groups:"group G" "group F"
  assumes HG:"H \<lhd> G"
  assumes \<phi>:"\<phi> \<in> iso G F"
  shows "(\<phi> ` H) \<lhd> F"
proof -
  from groups \<phi> have "group_hom G F \<phi>" unfolding group_hom_def group_hom_axioms_def iso_def by auto
  moreover from \<phi> have "\<phi> ` (carrier G) = carrier F" unfolding iso_def bij_betw_def by simp
  moreover note HG
  ultimately show ?thesis using normal.surj_hom_normal_subgroup by metis
qed

text \<open>The trivial subgroup is a subgroup:\<close>

lemma (in group) triv_subgroup:
  shows "subgroup {\<one>} G"
unfolding subgroup_def by auto

text \<open>The cardinality of the right cosets of the trivial subgroup is the cardinality of the group itself:\<close>

lemma (in group) card_rcosets_triv:
  assumes "finite (carrier G)"
  shows "card (rcosets {\<one>}) = order G"
proof -
  have "subgroup {\<one>} G" by (rule triv_subgroup)
  with assms have "card (rcosets {\<one>}) * card {\<one>} = order G"
    using lagrange by blast
  thus ?thesis by (auto simp:card_Suc_eq)
qed

text \<open>The intersection of two normal subgroups is, again, a normal subgroup.\<close>

lemma (in group) normal_subgroup_intersect:
  assumes "M \<lhd> G" and "N \<lhd> G"
  shows "M \<inter> N \<lhd> G"
using assms subgroup_intersect is_group normal_inv_iff by simp

text \<open>The set product of two normal subgroups is a normal subgroup.\<close>

lemma (in group) setmult_lcos_assoc:
     "\<lbrakk>H \<subseteq> carrier G; K \<subseteq> carrier G; x \<in> carrier G\<rbrakk>
      \<Longrightarrow> (x <# H) <#> K = x <# (H <#> K)"
by (force simp add: l_coset_def set_mult_def m_assoc)

lemma (in group) normal_subgroup_set_mult_closed:
  assumes "M \<lhd> G" and "N \<lhd> G"
  shows "M <#> N \<lhd> G"
proof (rule normalI)
  from assms show "subgroup (M <#> N) G"
    using second_isomorphism_grp.normal_set_mult_subgroup normal_imp_subgroup
    unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def by force
next
  show "\<forall>x\<in>carrier G. M <#> N #> x = x <# (M <#> N)"
  proof
    fix x
    assume x:"x \<in> carrier G"
    have "M <#> N #> x = M <#> (N #> x)" by (metis assms(1,2) normal_inv_iff setmult_rcos_assoc subgroup.subset x)
    also have "\<dots> = M <#> (x <# N)" by (metis assms(2) normal.coset_eq x)
    also have "\<dots> = (M #> x) <#> N" by (metis assms(1,2) normal_imp_subgroup rcos_assoc_lcos subgroup.subset x)
    also have "\<dots> = (x <# M) <#> N" by (metis assms(1) normal.coset_eq x)
    also have "\<dots> = x <# (M <#> N)" by (metis assms(1,2) normal_imp_subgroup setmult_lcos_assoc subgroup.subset x)
    finally show "M <#> N #> x = x <# (M <#> N)".
  qed
qed

text \<open>The following is a very basic lemma about subgroups: If restricting the carrier of
  a group yields a group it's a subgroup of the group we've started with.\<close>

lemma (in group) restrict_group_imp_subgroup:
  assumes "H \<subseteq> carrier G" "group (G\<lparr>carrier := H\<rparr>)"
  shows "subgroup H G"
proof
  from assms(1) show "H \<subseteq> carrier G" .
next
  fix x y
  assume "x \<in> H" "y \<in> H"
  hence "x \<in> carrier (G\<lparr>carrier := H\<rparr>)" "y \<in> carrier (G\<lparr>carrier := H\<rparr>)" by auto
  with assms(2) show "x \<otimes> y \<in> H" using assms(2) group.is_monoid monoid.m_closed by fastforce
next
  show "\<one> \<in> H" using assms(2) group.is_monoid monoid.one_closed by fastforce
next
  fix x
  assume "x \<in> H"
  hence x:"x \<in> carrier (G\<lparr>carrier := H\<rparr>)" by auto
  hence "inv\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> x \<in> carrier (G\<lparr>carrier := H\<rparr>)" using assms(2) group.inv_closed by fastforce
  hence "inv\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> x \<in> carrier G" using x assms(1) by auto
  moreover have "inv\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> x \<otimes> x = \<one>" using assms(2) group.l_inv x by fastforce
  moreover have "x \<in> carrier G" using x assms(1) by auto
  ultimately have "inv\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> x = inv x" using inv_equality[symmetric] by auto
  thus "inv x \<in> H" using assms(2) group.inv_closed x by fastforce
qed

text \<open>A subgroup relation survives factoring by a normal subgroup.\<close>

lemma (in group) normal_subgroup_factorize:
  assumes "N \<lhd> G" and "N \<subseteq> H" and "subgroup H G"
  shows "subgroup (rcosets\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> N) (G Mod N)"
proof -
  interpret GModN: group "G Mod N" using assms(1) by (rule normal.factorgroup_is_group)
  have "N \<lhd> G\<lparr>carrier := H\<rparr>" using assms by (metis normal_restrict_supergroup)
  hence grpHN:"group (G\<lparr>carrier := H\<rparr> Mod N)" by (rule normal.factorgroup_is_group)
  have "(<#>\<^bsub>G\<lparr>carrier:=H\<rparr>\<^esub>) = (\<lambda>U K. (\<Union>h\<in>U. \<Union>k\<in>K. {h \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> k}))" using set_mult_def by metis
  moreover have "\<dots> = (\<lambda>U K. (\<Union>h\<in>U. \<Union>k\<in>K. {h \<otimes>\<^bsub>G\<^esub> k}))" by auto
  moreover have "(<#>) = (\<lambda>U K. (\<Union>h\<in>U. \<Union>k\<in>K. {h \<otimes> k}))" using set_mult_def by metis
  ultimately have "(<#>\<^bsub>G\<lparr>carrier:=H\<rparr>\<^esub>) = (<#>\<^bsub>G\<^esub>)" by simp
  with grpHN have "group ((G Mod N)\<lparr>carrier := (rcosets\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> N)\<rparr>)" unfolding FactGroup_def by auto
  moreover have "rcosets\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> N \<subseteq> carrier (G Mod N)" unfolding FactGroup_def RCOSETS_def r_coset_def
    using assms(3) subgroup.subset by fastforce
  ultimately show ?thesis using GModN.is_group group.restrict_group_imp_subgroup by auto
qed

text \<open>A normality relation survives factoring by a normal subgroup.\<close>

lemma (in group) normality_factorization:
  assumes NG:"N \<lhd> G" and NH:"N \<subseteq> H" and HG:"H \<lhd> G"
  shows "(rcosets\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> N) \<lhd> (G Mod N)"
proof -
  from assms(1) interpret GModN: group "G Mod N" by (metis normal.factorgroup_is_group)
  show ?thesis
  proof (auto simp: GModN.normal_inv_iff)
    from assms show "subgroup (rcosets\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> N) (G Mod N)" using normal_imp_subgroup normal_subgroup_factorize by force
  next
    fix U V
    assume U:"U \<in> carrier (G Mod N)" and V:"V \<in> rcosets\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> N"
    then obtain g where g:"g \<in> carrier G" "U = N #> g" unfolding FactGroup_def RCOSETS_def by auto
    from V obtain h where h:"h \<in> H" "V = N #> h" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
    hence hG:"h \<in> carrier G" using HG normal_imp_subgroup subgroup.mem_carrier by force
    hence ghG:"g \<otimes> h \<in> carrier G" using g m_closed by auto
    from g h have "g \<otimes> h \<otimes> inv g \<in> H" using HG normal_inv_iff by auto
    moreover have "U <#> V <#> inv\<^bsub>G Mod N\<^esub> U = N #> (g \<otimes> h \<otimes> inv g)"
    proof -
      from g U have "inv\<^bsub>G Mod N\<^esub> U = N #> inv g" using NG normal.inv_FactGroup normal.rcos_inv by fastforce
      hence "U <#> V <#> inv\<^bsub>G Mod N\<^esub> U = (N #> g) <#> (N #> h) <#> (N #> inv g)" using g h by simp
      also have "\<dots> = N #> (g \<otimes> h) <#> (N #> inv g)" using g hG NG normal.rcos_sum by force
      also have "\<dots> = N #> (g \<otimes> h \<otimes> inv g)" using g inv_closed ghG NG normal.rcos_sum by force
      finally show ?thesis .
    qed
    ultimately show "U <#> V <#> inv\<^bsub>G Mod N\<^esub> U \<in> rcosets\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> N" unfolding RCOSETS_def r_coset_def by auto
  qed
qed

text \<open>Factoring by a normal subgroups yields the trivial group iff the subgroup is the whole group.\<close>

lemma (in normal) fact_group_trivial_iff:
  assumes "finite (carrier G)"
  shows "(carrier (G Mod H) = {\<one>\<^bsub>G Mod H\<^esub>}) = (H = carrier G)"
proof
  assume "carrier (G Mod H) = {\<one>\<^bsub>G Mod H\<^esub>}"
  moreover with assms lagrange have "order (G Mod H) * card H = order G" unfolding FactGroup_def order_def using is_subgroup by force
  ultimately have "card H = order G" unfolding order_def by auto
  thus "H = carrier G" using subgroup.subset is_subgroup assms card_subset_eq unfolding order_def
    by metis
next
  from assms have ordergt0:"order G > 0" unfolding order_def by (metis subgroup.finite_imp_card_positive subgroup_self)
  assume "H = carrier G"
  hence "card H = order G" unfolding order_def by simp
  with assms is_subgroup lagrange have "card (rcosets H) * order G = order G" by metis
  with ordergt0 have "card (rcosets H) = 1" by (metis mult_eq_self_implies_10 mult.commute neq0_conv)
  hence "order (G Mod H) = 1" unfolding order_def FactGroup_def by auto
  thus "carrier (G Mod H) = {\<one>\<^bsub>G Mod H\<^esub>}" using factorgroup_is_group by (metis group.order_one_triv_iff)
qed

text \<open>Finite groups have finite quotients.\<close>

lemma (in normal) factgroup_finite:
  assumes "finite (carrier G)"
  shows "finite (rcosets H)"
using assms unfolding RCOSETS_def by auto

text \<open>The union of all the cosets contained in a subgroup of a quotient group acts as a represenation for that subgroup.\<close>

lemma (in normal) factgroup_subgroup_union_char:
  assumes "subgroup A (G Mod H)"
  shows "(\<Union>A) = {x \<in> carrier G. H #> x \<in> A}"
proof
  show "\<Union>A \<subseteq> {x \<in> carrier G. H #> x \<in> A}"
  proof
    fix x
    assume x:"x \<in> \<Union>A"
    then obtain a where a:"a \<in> A" "x \<in> a" by auto
    with assms have xx:"x \<in> carrier G" using subgroup.subset unfolding FactGroup_def RCOSETS_def r_coset_def by force
    from assms a obtain y where y:"y \<in> carrier G" "a = H #> y" using subgroup.subset unfolding FactGroup_def RCOSETS_def by force
    with a have "x \<in> H #> y" by simp
    hence "H #> y = H #> x" using y is_subgroup repr_independence by auto
    with y(2) a(1) have "H #> x \<in> A" by auto
    with xx show "x \<in> {x \<in> carrier G. H #> x \<in> A}" by simp
  qed
next
  show "{x \<in> carrier G. H #> x \<in> A} \<subseteq> \<Union>A"
  proof
    fix x
    assume x:"x \<in> {x \<in> carrier G. H #> x \<in> A}"
    hence xx:"x \<in> carrier G" "H #> x \<in> A" by auto
    moreover have "x \<in> H #> x" by (metis is_subgroup rcos_self xx(1))
    ultimately show "x \<in> \<Union>A" by auto
  qed
qed

lemma (in normal) factgroup_subgroup_union_subgroup:
  assumes "subgroup A (G Mod H)"
  shows "subgroup (\<Union>A) G"
proof -
  have "subgroup {x \<in> carrier G. H #> x \<in> A} G"
  proof
    show "{x \<in> carrier G. H #> x \<in> A} \<subseteq> carrier G" by auto
  next
    fix x y
    assume "x \<in> {x \<in> carrier G. H #> x \<in> A}" and "y \<in> {x \<in> carrier G. H #> x \<in> A}"
    hence x:"x \<in> carrier G" "H #> x \<in> A" and y:"y \<in> carrier G" "H #> y \<in> A" by auto
    hence xyG:"x \<otimes> y \<in> carrier G" by (metis m_closed)
    from assms x y have "(H #> x) <#> (H #> y) \<in> A" using subgroup.m_closed unfolding FactGroup_def by fastforce
    hence "H #> (x \<otimes> y) \<in> A" by (metis rcos_sum x(1) y(1))
    with xyG show "x \<otimes> y \<in> {x \<in> carrier G. H #> x \<in> A}" by simp
  next
    have "H #> \<one> \<in> A" using assms subgroup.one_closed unfolding FactGroup_def by (metis coset_mult_one monoid.select_convs(2) subset)
    with assms one_closed show "\<one> \<in> {x \<in> carrier G. H #> x \<in> A}" by simp
  next
    fix x
    assume "x \<in> {x \<in> carrier G. H #> x \<in> A}"
    hence x:"x \<in> carrier G" "H #> x \<in> A" by auto
    hence invx:"inv x \<in> carrier G" using inv_closed by simp
    from assms x have "set_inv (H #> x) \<in> A" using subgroup.m_inv_closed by (metis inv_FactGroup subgroup.mem_carrier)
    hence "H #> (inv x) \<in> A" by (metis rcos_inv x(1))
    with invx show "inv x \<in> {x \<in> carrier G. H #> x \<in> A}" by simp
  qed
  with assms factgroup_subgroup_union_char show ?thesis by auto
qed

lemma (in normal) factgroup_subgroup_union_normal:
  assumes "A \<lhd> (G Mod H)"
  shows "\<Union>A \<lhd> G"
proof -
  have "{x \<in> carrier G. H #> x \<in> A} \<lhd> G"
  unfolding normal_def normal_axioms_def
  proof auto (*(auto del: equalityI)*)
    from assms show "subgroup {x \<in> carrier G. H #> x \<in> A} G"
      by (metis (full_types) factgroup_subgroup_union_char factgroup_subgroup_union_subgroup normal_imp_subgroup)
  next
    interpret Anormal: normal A "(G Mod H)" using assms by simp
    fix x y
    assume x:"x \<in> carrier G" "y \<in> {x \<in> carrier G. H #> x \<in> A} #> x"
    then obtain x' where "x' \<in> {x \<in> carrier G. H #> x \<in> A}" "y = x' \<otimes> x" unfolding r_coset_def by auto
    hence x':"x' \<in> carrier G" "H #> x' \<in> A" by auto
    from x(1) have Hx:"H #> x \<in> carrier (G Mod H)" unfolding FactGroup_def RCOSETS_def by force
    with x' have "(inv\<^bsub>G Mod H\<^esub> (H #> x)) \<otimes>\<^bsub>G Mod H\<^esub> (H #> x') \<otimes>\<^bsub>G Mod H\<^esub> (H #> x) \<in> A" using Anormal.inv_op_closed1 by auto
    hence "(set_inv (H #> x)) <#> (H #> x') <#> (H #> x) \<in> A" using inv_FactGroup Hx unfolding FactGroup_def by auto
    hence "(H #> (inv x)) <#> (H #> x') <#> (H #> x) \<in> A" using x(1) by (metis rcos_inv)
    hence "(H #> (inv x \<otimes> x')) <#> (H #> x) \<in> A" by (metis inv_closed rcos_sum x'(1) x(1))
    hence "H #> (inv x \<otimes> x' \<otimes> x) \<in> A" by (metis inv_closed m_closed rcos_sum x'(1) x(1))
    moreover have "inv x \<otimes> x' \<otimes> x \<in> carrier G" using x x' by (metis inv_closed m_closed)
    ultimately have "inv x \<otimes> x' \<otimes> x \<in> {x \<in> carrier G. H #> x \<in> A}" by auto
    hence xcoset:"x \<otimes> (inv x \<otimes> x' \<otimes> x) \<in> x <# {x \<in> carrier G. H #> x \<in> A}" unfolding l_coset_def using x(1) by auto
    have "x \<otimes> (inv x \<otimes> x' \<otimes> x) = (x \<otimes> inv x) \<otimes> x' \<otimes> x" by (metis Units_eq Units_inv_Units m_assoc m_closed x'(1) x(1))
    also have "\<dots> = x' \<otimes> x" by (metis l_one r_inv x'(1) x(1))
    also have "\<dots> = y" by (metis \<open>y = x' \<otimes> x\<close>)
    finally have "x \<otimes> (inv x \<otimes> x' \<otimes> x) = y".
    with xcoset show "y \<in> x <# {x \<in> carrier G. H #> x \<in> A}" by auto
  next
    interpret Anormal: normal A "(G Mod H)" using assms by simp
    fix x y
    assume x:"x \<in> carrier G" "y \<in> x <# {x \<in> carrier G. H #> x \<in> A}"
    then obtain x' where "x' \<in> {x \<in> carrier G. H #> x \<in> A}" "y = x \<otimes> x'" unfolding l_coset_def by auto
    hence x':"x' \<in> carrier G" "H #> x' \<in> A" by auto
    from x(1) have invx:"inv x \<in> carrier G" by (rule inv_closed)
    hence Hinvx:"H #> (inv x) \<in> carrier (G Mod H)" unfolding FactGroup_def RCOSETS_def by force
    with x' have "(inv\<^bsub>G Mod H\<^esub> (H #> inv x)) \<otimes>\<^bsub>G Mod H\<^esub> (H #> x') \<otimes>\<^bsub>G Mod H\<^esub> (H #> inv x) \<in> A" using invx Anormal.inv_op_closed1 by auto
    hence "(set_inv (H #> inv x)) <#> (H #> x') <#> (H #> inv x) \<in> A" using inv_FactGroup Hinvx unfolding FactGroup_def by auto
    hence "(H #> inv (inv x)) <#> (H #> x') <#> (H #> inv x) \<in> A" using invx by (metis rcos_inv)
    hence "(H #> x) <#> (H #> x') <#> (H #> inv x) \<in> A" by (metis inv_inv x(1))
    hence "(H #> (x \<otimes> x')) <#> (H #> inv x) \<in> A" by (metis rcos_sum x'(1) x(1))
    hence "H #> (x \<otimes> x' \<otimes> inv x) \<in> A" by (metis inv_closed m_closed rcos_sum x'(1) x(1))
    moreover have "x \<otimes> x' \<otimes> inv x \<in> carrier G" using x x' by (metis inv_closed m_closed)
    ultimately have "x \<otimes> x' \<otimes> inv x \<in> {x \<in> carrier G. H #> x \<in> A}" by auto
    hence xcoset:"(x \<otimes> x' \<otimes> inv x) \<otimes> x \<in> {x \<in> carrier G. H #> x \<in> A} #> x" unfolding r_coset_def using invx by auto
    have "(x \<otimes> x' \<otimes> inv x) \<otimes> x = (x \<otimes> x') \<otimes> (inv x \<otimes> x)" by (metis Units_eq Units_inv_Units m_assoc m_closed x'(1) x(1))
    also have "\<dots> = x \<otimes> x'" using x(1) l_inv x'(1) m_closed r_one by auto
    also have "\<dots> = y" by (metis \<open>y = x \<otimes> x'\<close>)
    finally have "x \<otimes> x' \<otimes> inv x \<otimes> x = y".
    with xcoset show "y \<in> {x \<in> carrier G. H #> x \<in> A} #> x" by auto
  qed
  with assms show ?thesis by (metis (full_types) factgroup_subgroup_union_char normal_imp_subgroup)
qed

lemma (in normal) factgroup_subgroup_union_factor:
  assumes "subgroup A (G Mod H)"
  shows "A = rcosets\<^bsub>G\<lparr>carrier := \<Union>A\<rparr>\<^esub> H"
proof -
  have "A = rcosets\<^bsub>G\<lparr>carrier := {x \<in> carrier G. H #> x \<in> A}\<rparr>\<^esub> H"
  proof auto
    fix U
    assume U:"U \<in> A"
    then obtain x' where x':"x' \<in> carrier G" "U = H #> x'" using assms subgroup.subset unfolding FactGroup_def RCOSETS_def by force
    with U have "H #> x' \<in> A" by simp
    with x' show "U \<in> rcosets\<^bsub>G\<lparr>carrier := {x \<in> carrier G. H #> x \<in> A}\<rparr>\<^esub> H" unfolding RCOSETS_def r_coset_def by auto
  next
    fix U
    assume U:"U \<in> rcosets\<^bsub>G\<lparr>carrier := {x \<in> carrier G. H #> x \<in> A}\<rparr>\<^esub> H"
    then obtain x' where x':"x' \<in> {x \<in> carrier G. H #> x \<in> A}" "U = H #> x'" unfolding RCOSETS_def r_coset_def by auto
    hence "x' \<in> carrier G" "H #> x' \<in> A" by auto
    with x' show "U \<in> A" by simp
  qed
  with assms show ?thesis using factgroup_subgroup_union_char by auto
qed

section  \<open>Flattening the type of group carriers\<close>

text \<open>Flattening here means to convert the type of group elements from 'a set to 'a.
This is possible whenever the empty set is not an element of the group.\<close>

definition flatten where
  "flatten (G::('a set, 'b) monoid_scheme) rep = \<lparr>carrier=(rep ` (carrier G)),
      monoid.mult=(\<lambda> x y. rep ((the_inv_into (carrier G) rep x) \<otimes>\<^bsub>G\<^esub> (the_inv_into (carrier G) rep y))),
      one=rep \<one>\<^bsub>G\<^esub> \<rparr>"

lemma flatten_set_group_hom:
  assumes group:"group G"
  assumes inj:"inj_on rep (carrier G)"
  shows "rep \<in> hom G (flatten G rep)"
unfolding hom_def
proof auto
  fix g
  assume g:"g \<in> carrier G"
  thus "rep g \<in> carrier (flatten G rep)" unfolding flatten_def by auto
next
  fix g h
  assume g:"g \<in> carrier G" and h:"h \<in> carrier G"
  hence "rep g \<in> carrier (flatten G rep)" "rep h \<in> carrier (flatten G rep)" unfolding flatten_def by auto
  hence "rep g \<otimes>\<^bsub>flatten G rep\<^esub> rep h
    = rep (the_inv_into (carrier G) rep (rep g) \<otimes>\<^bsub>G\<^esub> the_inv_into (carrier G) rep (rep h))" unfolding flatten_def by auto
  also have "\<dots> = rep (g \<otimes>\<^bsub>G\<^esub> h)" using inj g h by (metis the_inv_into_f_f)
  finally show "rep (g \<otimes>\<^bsub>G\<^esub> h) = rep g \<otimes>\<^bsub>flatten G rep\<^esub> rep h"..
qed

lemma flatten_set_group:
  assumes group:"group G"
  assumes inj:"inj_on rep (carrier G)"
  shows "group (flatten G rep)"
proof (rule groupI)
  fix x y
  assume x:"x \<in> carrier (flatten G rep)" and y:"y \<in> carrier (flatten G rep)"
  define g h
    where "g = the_inv_into (carrier G) rep x"
      and "h = the_inv_into (carrier G) rep y"
  hence "x \<otimes>\<^bsub>flatten G rep\<^esub> y = rep (g \<otimes>\<^bsub>G\<^esub> h)" unfolding flatten_def by auto
  moreover from g_def h_def have "g \<in> carrier G" "h \<in> carrier G"
    using inj x y the_inv_into_into unfolding flatten_def by (metis partial_object.select_convs(1) subset_refl)+
  hence "g \<otimes>\<^bsub>G\<^esub> h \<in> carrier G" by (metis group group.is_monoid monoid.m_closed)
  hence "rep (g \<otimes>\<^bsub>G\<^esub> h) \<in> carrier (flatten G rep)" unfolding flatten_def by simp
  ultimately show "x \<otimes>\<^bsub>flatten G rep\<^esub> y \<in> carrier (flatten G rep)" by simp
next
  show "\<one>\<^bsub>flatten G rep\<^esub> \<in> carrier (flatten G rep)" unfolding flatten_def by (simp add: group group.is_monoid)
next
  fix x y z
  assume x:"x \<in> carrier (flatten G rep)" and y:"y \<in> carrier (flatten G rep)" and z:"z \<in> carrier (flatten G rep)"
  define g h k
    where "g = the_inv_into (carrier G) rep x"
      and "h = the_inv_into (carrier G) rep y"
      and "k = the_inv_into (carrier G) rep z"
  hence "x \<otimes>\<^bsub>flatten G rep\<^esub> y \<otimes>\<^bsub>flatten G rep\<^esub> z = (rep (g \<otimes>\<^bsub>G\<^esub> h)) \<otimes> \<^bsub>flatten G rep\<^esub> z" unfolding flatten_def by auto
  also have "\<dots> = rep (the_inv_into (carrier G) rep (rep (g \<otimes>\<^bsub>G\<^esub> h)) \<otimes>\<^bsub>G\<^esub> k)" using k_def unfolding flatten_def by auto
  also from g_def h_def k_def have ghkG:"g \<in> carrier G" "h \<in> carrier G" "k \<in> carrier G"
    using inj x y z the_inv_into_into unfolding flatten_def by fastforce+
  hence gh:"g \<otimes>\<^bsub>G\<^esub> h \<in> carrier G" and hk:"h \<otimes>\<^bsub>G\<^esub> k \<in> carrier G" by (metis group group.is_monoid monoid.m_closed)+
  hence "rep (the_inv_into (carrier G) rep (rep (g \<otimes>\<^bsub>G\<^esub> h)) \<otimes>\<^bsub>G\<^esub> k) = rep ((g \<otimes>\<^bsub>G\<^esub> h) \<otimes>\<^bsub>G\<^esub> k)"
    unfolding flatten_def using inj the_inv_into_f_f by fastforce
  also have "\<dots> = rep (g \<otimes>\<^bsub>G\<^esub> (h \<otimes>\<^bsub>G\<^esub> k))" using group group.is_monoid ghkG monoid.m_assoc by fastforce
  also have "\<dots> = x \<otimes>\<^bsub>flatten G rep\<^esub> (rep (h \<otimes>\<^bsub>G\<^esub> k))" unfolding g_def flatten_def using hk inj the_inv_into_f_f by fastforce
  also have "\<dots> = x \<otimes>\<^bsub>flatten G rep\<^esub> (y \<otimes>\<^bsub>flatten G rep\<^esub> z)" unfolding h_def k_def flatten_def using x y by force
  finally show "x \<otimes>\<^bsub>flatten G rep\<^esub> y \<otimes>\<^bsub>flatten G rep\<^esub> z = x \<otimes>\<^bsub>flatten G rep\<^esub> (y \<otimes>\<^bsub>flatten G rep\<^esub> z)".
next
  fix x
  assume x:"x \<in> carrier (flatten G rep)"
  define g where "g = the_inv_into (carrier G) rep x"
  hence gG:"g \<in> carrier G" using inj x unfolding flatten_def using the_inv_into_into by force
  have "\<one>\<^bsub>G\<^esub> \<in> (carrier G)" by (simp add: group group.is_monoid)
  hence "the_inv_into (carrier G) rep (\<one>\<^bsub>flatten G rep\<^esub>) = \<one>\<^bsub>G\<^esub>" unfolding flatten_def using the_inv_into_f_f inj by force
  hence "\<one>\<^bsub>flatten G rep\<^esub> \<otimes>\<^bsub>flatten G rep\<^esub> x = rep (\<one>\<^bsub>G\<^esub> \<otimes>\<^bsub>G\<^esub> g)" unfolding flatten_def g_def by simp
  also have "\<dots> = rep g" using gG group by (metis group.is_monoid monoid.l_one)
  also have "\<dots> = x" unfolding g_def using inj x f_the_inv_into_f unfolding flatten_def by force
  finally show "\<one>\<^bsub>flatten G rep\<^esub> \<otimes>\<^bsub>flatten G rep\<^esub> x = x".
next
  from group inj have hom:"rep \<in> hom G (flatten G rep)" using flatten_set_group_hom by auto
  fix x
  assume x:"x \<in> carrier (flatten G rep)"
  define g where "g = the_inv_into (carrier G) rep x"
  hence gG:"g \<in> carrier G" using inj x unfolding flatten_def using the_inv_into_into by force
  hence invG:"inv\<^bsub>G\<^esub> g \<in> carrier G" by (metis group group.inv_closed)
  hence "rep (inv\<^bsub>G\<^esub> g) \<in> carrier (flatten G rep)" unfolding flatten_def by auto
  moreover have "rep (inv\<^bsub>G\<^esub> g) \<otimes>\<^bsub>flatten G rep\<^esub> x = rep (inv\<^bsub>G\<^esub> g) \<otimes>\<^bsub>flatten G rep\<^esub> (rep g)"
    unfolding g_def using f_the_inv_into_f inj x unfolding flatten_def by fastforce
  hence "rep (inv\<^bsub>G\<^esub> g) \<otimes>\<^bsub>flatten G rep\<^esub> x = rep (inv\<^bsub>G\<^esub> g \<otimes>\<^bsub>G\<^esub> g)"
    using hom unfolding hom_def using gG invG hom_def by auto
  hence "rep (inv\<^bsub>G\<^esub> g) \<otimes>\<^bsub>flatten G rep\<^esub> x = rep \<one>\<^bsub>G\<^esub>" using invG gG by (metis group group.l_inv)
  hence "rep (inv\<^bsub>G\<^esub> g) \<otimes>\<^bsub>flatten G rep\<^esub> x = \<one>\<^bsub>flatten G rep\<^esub>" unfolding flatten_def by auto
  ultimately show "\<exists>y\<in>carrier (flatten G rep). y \<otimes>\<^bsub>flatten G rep\<^esub> x = \<one>\<^bsub>flatten G rep\<^esub>" by auto
qed

lemma (in normal) flatten_set_group_mod_inj:
  shows "inj_on (\<lambda>U. SOME g. g \<in> U) (carrier (G Mod H))"
proof (rule inj_onI)
  fix U V
  assume U:"U \<in> carrier (G Mod H)" and V:"V \<in> carrier (G Mod H)"
  then obtain g h where g:"U = H #> g" "g \<in> carrier G" and h:"V = H #> h" "h \<in> carrier G"
    unfolding FactGroup_def RCOSETS_def by auto
  hence notempty:"U \<noteq> {}" "V \<noteq> {}" by (metis empty_iff is_subgroup rcos_self)+
  assume "(SOME g. g \<in> U) = (SOME g. g \<in> V)"
  with notempty have "(SOME g. g \<in> U) \<in> U \<inter> V" by (metis IntI ex_in_conv someI)
  thus "U = V" by (metis Int_iff g h is_subgroup repr_independence)
qed

lemma (in normal) flatten_set_group_mod:
  shows "group (flatten (G Mod H) (\<lambda>U. SOME g. g \<in> U))"
using factorgroup_is_group flatten_set_group_mod_inj by (rule flatten_set_group)

lemma (in normal) flatten_set_group_mod_iso:
  shows "(\<lambda>U. SOME g. g \<in> U) \<in> iso (G Mod H) (flatten (G Mod H) (\<lambda>U. SOME g. g \<in> U))"
unfolding iso_def bij_betw_def
apply (auto)
 apply (metis flatten_set_group_mod_inj factorgroup_is_group flatten_set_group_hom)
 apply (rule flatten_set_group_mod_inj)
 unfolding flatten_def apply (auto)
done

end


header {*Program Statements as Predicate Transformers*}

theory Statements
imports Preliminaries
begin

text {*
  Program statements are modeled as predicate transformers, functions from predicates to predicates.
  If $\mathit{State}$ is the type of program states, then a program $S$ is a a function from
  $\mathit{State}\ \mathit{set}$ to
  $\mathit{State}\ \mathit{set}$. If $q \in \mathit{State}\ \mathit{set}$, then the elements of
  $S\ q$ are the initial states from which
  $S$ is guarantied to terminate in a state from $q$.

  However, most of the time we will work with an arbitrary compleate lattice, or an arbitrary boolean algebra
  instead of the complete boolean algebra of predicate transformers.

  We will introduce in this section assert, assume, demonic choice, angelic choice, demonic update, and
  angelic update statements. We will prove also that these statements are monotonic.
*}

lemma mono_top[simp]: "mono top"
  by (simp add: mono_def top_fun_def)

lemma mono_choice[simp]: "mono S \<Longrightarrow> mono T \<Longrightarrow> mono (S \<sqinter> T)"
  apply (simp add: mono_def inf_fun_def)
  apply safe
  apply (rule_tac y = "S x" in order_trans)
  apply simp_all
  apply (rule_tac y = "T x" in order_trans)
  by simp_all

subsection "Assert statement"

text {*
The assert statement of a predicate $p$ when executed from a state $s$ fails
if $s\not\in p$ and behaves as skip otherwise.
*}

definition
  assert::"'a::semilattice_inf \<Rightarrow> 'a \<Rightarrow> 'a" ("{. _ .}" [0] 1000) where
  "{.p.} q \<equiv>  p \<sqinter> q"

lemma mono_assert [simp]: "mono {.p.}"
  apply (simp add: assert_def mono_def, safe)
  apply (rule_tac y = "x" in order_trans)
  by simp_all

subsection "Assume statement"

text {*
The assume statement of a predicate $p$ when executed from a state $s$ is not enabled
if $s\not\in p$ and behaves as skip otherwise.
*}

definition
  "assume" :: "'a::boolean_algebra \<Rightarrow> 'a \<Rightarrow> 'a" ("[. _ .]" [0] 1000) where
  "[. p .] q \<equiv>  -p \<squnion> q"

lemma mono_assume [simp]: "mono (assume P)"
  apply (simp add: assume_def mono_def)
  apply safe
  apply (rule_tac y = "y" in order_trans)
  by simp_all

subsection "Demonic update statement"

text {*
The demonic update statement of a relation $Q: \mathit{State} \to \mathit{Sate} \to bool$,
when executed in a state $s$ computes nondeterministically a new state $s'$ such
$Q\ s \ s'$ is true. In order for this statement to be correct all
possible choices of $s'$ should be correct. If there is no state $s'$
such that $Q\ s \ s'$, then the demonic update of $Q$ is not enabled
in $s$.
*}

definition
  demonic :: "('a \<Rightarrow> 'b\<Colon>ord) \<Rightarrow> 'b\<Colon>ord \<Rightarrow> 'a set" ("[: _ :]" [0] 1000) where
  "[:Q:] p = {s . Q s \<le> p}"

lemma mono_demonic [simp]: "mono [:Q:]"
  apply (simp add: mono_def demonic_def)
  by auto

theorem demonic_bottom:
  "[:R:] (\<bottom>::('a::order_bot)) = {s . (R s) = \<bottom>}"
  apply (unfold demonic_def, safe, simp_all)
  apply (rule antisym)
  by auto

theorem demonic_bottom_top [simp]:
  "[:(\<bottom>::_::order_bot):]  = \<top>"
  by (simp add: fun_eq_iff inf_fun_def sup_fun_def demonic_def top_fun_def bot_fun_def)

theorem demonic_sup_inf:
  "[:Q \<squnion> Q':] = [:Q:] \<sqinter> [:Q':]"
  by (simp add: fun_eq_iff sup_fun_def inf_fun_def demonic_def, blast)

subsection "Angelic update statement"

text {*
The angelic update statement of a relation $Q: \mathit{State} \to \mathit{State} \to \mathit{bool}$ is similar
to the demonic version, except that it is enough that at least for one choice $s'$, $Q \ s \ s'$
is correct. If there is no state $s'$
such that $Q\ s \ s'$, then the angelic update of $Q$ fails in $s$.
*}

definition
  angelic :: "('a \<Rightarrow> 'b\<Colon>{semilattice_inf,order_bot}) \<Rightarrow> 'b \<Rightarrow> 'a set"
               ("{: _ :}" [0] 1000) where
  "{:Q:} p = {s . (Q s) \<sqinter> p \<noteq> \<bottom>}"

syntax "_update" :: "patterns => patterns => logic => logic" ("_ \<leadsto> _ . _" 0)
translations
  "_update (_patterns x xs) (_patterns y ys) t" == "CONST id (_abs
           (_pattern x xs) (_Coll (_pattern y ys) t))"
  "_update x y t" == "CONST id (_abs x (_Coll y t))"

term "{: y, z \<leadsto> x, z' . P x y z z' :}"

theorem angelic_bottom [simp]:
  "angelic R \<bottom>  = {}"
  by (simp add: angelic_def inf_bot_bot)

theorem angelic_disjunctive [simp]:
  "{:(R::('a \<Rightarrow> 'b::complete_distrib_lattice)):} \<in> Apply.Disjunctive"
  by (simp add: Apply.Disjunctive_def angelic_def inf_Sup, blast)

subsection "The guard of a statement"

text {*
The guard of a statement $S$ is the set of iniatial states from which $S$
is enabled or fails.
*}

definition
  "((grd S)::'a::boolean_algebra) = - (S bot)"

lemma grd_choice[simp]: "grd (S \<sqinter> T) = (grd S) \<squnion> (grd T)"
  by (simp add: grd_def inf_fun_def)

lemma grd_demonic: "grd [:Q:] = {s . \<exists> s' . s' \<in> (Q s) }"
  apply (simp add: grd_def demonic_def)
  by blast

lemma grd_demonic_2[simp]: "(s \<notin> grd [:Q:]) = (\<forall> s' . s' \<notin>  (Q s))"
  by (simp add: grd_demonic)

theorem grd_angelic:
  "grd {:R:} = UNIV"
  by (simp add: grd_def)

end


chapter \<open> Implication Logic \label{sec:implicational-intuitionistic-logic} \<close>

theory Implication_Logic
  imports Main
begin

text \<open> This theory presents the pure implicational fragment of
       intuitionistic logic. That is to say, this is the fragment of
       intuitionistic logic containing \<^emph>\<open>implication only\<close>, and no other
       connectives nor \<^emph>\<open>falsum\<close> (i.e., \<open>\<bottom>\<close>). We shall refer to this logic as
       \<^emph>\<open>implication logic\<close> in future discussion. \<close>

text \<open> For further reference see @{cite urquhartImplicationalFormulasIntuitionistic1974}.\<close>

section \<open> Axiomatization \<close>

text \<open> Implication logic can be given by the a Hilbert-style  axiom system,
       following Troelstra and Schwichtenberg
       @{cite \<open>\S 1.3.9, pg. 33\<close> troelstraBasicProofTheory2000}. \<close>

class implication_logic =
  fixes deduction :: "'a \<Rightarrow> bool" ("\<turnstile> _" [60] 55)
  fixes implication :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 70)
  assumes axiom_k: "\<turnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<phi>"
  assumes axiom_s: "\<turnstile> (\<phi> \<rightarrow> \<psi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> \<rightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<chi>"
  assumes modus_ponens: "\<turnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<turnstile> \<phi> \<Longrightarrow> \<turnstile> \<psi>"

section \<open> Common Rules \<close>

lemma (in implication_logic) trivial_implication:
  "\<turnstile> \<phi> \<rightarrow> \<phi>"
  by (meson axiom_k axiom_s modus_ponens)

lemma (in implication_logic) flip_implication:
  "\<turnstile> (\<phi> \<rightarrow> \<psi> \<rightarrow> \<chi>) \<rightarrow> \<psi> \<rightarrow> \<phi> \<rightarrow> \<chi>"
  by (meson axiom_k axiom_s modus_ponens)

lemma (in implication_logic) hypothetical_syllogism:
  "\<turnstile> (\<psi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> \<rightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<chi>"
  by (meson axiom_k axiom_s modus_ponens)

lemma (in implication_logic) flip_hypothetical_syllogism:
  "\<turnstile> (\<psi> \<rightarrow> \<phi>) \<rightarrow> (\<phi> \<rightarrow> \<chi>) \<rightarrow> (\<psi> \<rightarrow> \<chi>)"
  using modus_ponens flip_implication hypothetical_syllogism by blast

lemma (in implication_logic) implication_absorption:
  "\<turnstile> (\<phi> \<rightarrow> \<phi> \<rightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<psi>"
  by (meson axiom_k axiom_s modus_ponens)

section \<open> Lists of Assumptions \<close>

subsection \<open> List Implication \<close>

text \<open> Implication given a list of assumptions can be expressed recursively \<close>

primrec (in implication_logic)
  list_implication :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a" (infix ":\<rightarrow>" 80) where
    "[] :\<rightarrow> \<phi> = \<phi>"
  | "(\<psi> # \<Psi>) :\<rightarrow> \<phi> = \<psi> \<rightarrow> \<Psi> :\<rightarrow> \<phi>"

subsection \<open> Deduction From a List of Assumptions \label{sec:list-deduction}\<close>

text \<open> Deduction from a list of assumptions can be expressed in terms of
       @{term "(:\<rightarrow>)"}. \<close>

definition (in implication_logic) list_deduction :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" (infix ":\<turnstile>" 60)
  where
    "\<Gamma> :\<turnstile> \<phi> \<equiv> \<turnstile> \<Gamma> :\<rightarrow> \<phi>"

subsection \<open> List Deduction as Implication Logic \<close>

text \<open> The relation @{term "(:\<turnstile>)"} may naturally be interpreted as a
       @{term "deduction"} predicate for an instance of implication logic
       for a fixed list of assumptions @{term "\<Gamma>"}. \<close>

text \<open> Analogues of the two axioms of implication logic can be
       naturally stated using list implication. \<close>

lemma (in implication_logic) list_implication_axiom_k:
  "\<turnstile> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<phi>"
  by (induct \<Gamma>, (simp, meson axiom_k axiom_s modus_ponens)+)

lemma (in implication_logic) list_implication_axiom_s:
  "\<turnstile> \<Gamma> :\<rightarrow> (\<phi> \<rightarrow> \<psi>) \<rightarrow> \<Gamma> :\<rightarrow> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<psi>"
  by (induct \<Gamma>,
      (simp, meson axiom_k axiom_s modus_ponens hypothetical_syllogism)+)

text \<open> The lemmas @{thm list_implication_axiom_k [no_vars]} and
       @{thm list_implication_axiom_s [no_vars]} jointly give rise to an
       interpretation of implication logic, where a list of assumptions
       @{term "\<Gamma>"} play the role of a \<^emph>\<open>background theory\<close> of @{term "(:\<turnstile>)"}. \<close>

context implication_logic begin
interpretation list_deduction_logic:
   implication_logic "\<lambda> \<phi>. \<Gamma> :\<turnstile> \<phi>" "(\<rightarrow>)"
proof qed
  (meson
     list_deduction_def
     axiom_k
     axiom_s
     modus_ponens
     list_implication_axiom_k
     list_implication_axiom_s)+
end

text \<open> The following \<^emph>\<open>weakening\<close> rule can also be derived. \<close>

lemma (in implication_logic) list_deduction_weaken:
  "\<turnstile> \<phi> \<Longrightarrow> \<Gamma> :\<turnstile> \<phi>"
  unfolding list_deduction_def
  using modus_ponens list_implication_axiom_k
  by blast

text \<open> In the case of the empty list, the converse may be established. \<close>

lemma (in implication_logic) list_deduction_base_theory [simp]:
  "[] :\<turnstile> \<phi> \<equiv> \<turnstile> \<phi>"
  unfolding list_deduction_def
  by simp

lemma (in implication_logic) list_deduction_modus_ponens:
  "\<Gamma> :\<turnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<Gamma> :\<turnstile> \<phi> \<Longrightarrow> \<Gamma> :\<turnstile> \<psi>"
  unfolding list_deduction_def
  using modus_ponens list_implication_axiom_s
  by blast

section \<open> The Deduction Theorem \<close>

text \<open> One result in the meta-theory of implication logic
       is the \<^emph>\<open>deduction theorem\<close>, which is a mechanism for moving
       antecedents back and forth from collections of assumptions. \<close>

text \<open> To develop the deduction theorem, the following two lemmas generalize
       @{thm "flip_implication" [no_vars]}. \<close>

lemma (in implication_logic) list_flip_implication1:
  "\<turnstile> (\<phi> # \<Gamma>) :\<rightarrow> \<chi> \<rightarrow> \<Gamma> :\<rightarrow> (\<phi> \<rightarrow> \<chi>)"
  by (induct \<Gamma>,
      (simp,
         meson
           axiom_k
           axiom_s
           modus_ponens
           flip_implication
           hypothetical_syllogism)+)

lemma (in implication_logic) list_flip_implication2:
  "\<turnstile> \<Gamma> :\<rightarrow> (\<phi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> # \<Gamma>) :\<rightarrow> \<chi>"
  by (induct \<Gamma>,
      (simp,
         meson
           axiom_k
           axiom_s
           modus_ponens
           flip_implication
           hypothetical_syllogism)+)

text \<open> Together the two lemmas above suffice to prove a form of
       the deduction theorem: \<close>

theorem (in implication_logic) list_deduction_theorem:
  "(\<phi> # \<Gamma>) :\<turnstile> \<psi> = \<Gamma> :\<turnstile> \<phi> \<rightarrow> \<psi>"
  unfolding list_deduction_def
  by (metis modus_ponens list_flip_implication1 list_flip_implication2)

section \<open> Monotonic Growth in Deductive Power \<close>

text \<open> In logic, for two sets of assumptions @{term "\<Phi>"} and @{term "\<Psi>"},
        if @{term "\<Psi> \<subseteq> \<Phi>"} then the latter theory @{term "\<Phi>"} is
        said to be \<^emph>\<open>stronger\<close> than former theory @{term "\<Psi>"}.
        In principle, anything a weaker theory can prove a
        stronger theory can prove. One way of saying this is
        that deductive power increases monotonically with as the set of
        underlying assumptions grow. \<close>

text \<open> The monotonic growth of deductive power can be expressed as a
       meta-theorem in implication logic. \<close>

text \<open> The lemma @{thm "list_flip_implication2" [no_vars]} presents a means
       of \<^emph>\<open>introducing\<close> assumptions into a list of assumptions when
       those assumptions have been arrived at by an implication. The next
       lemma presents a means of \<^emph>\<open>discharging\<close> those assumptions, which can
       be used in the monotonic growth theorem to be proved. \<close>

lemma (in implication_logic) list_implication_removeAll:
  "\<turnstile> \<Gamma> :\<rightarrow> \<psi> \<rightarrow> (removeAll \<phi> \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
proof -
  have "\<forall> \<psi>. \<turnstile> \<Gamma> :\<rightarrow> \<psi> \<rightarrow> (removeAll \<phi> \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
  proof(induct \<Gamma>)
    case Nil
    then show ?case by (simp, meson axiom_k)
  next
    case (Cons \<chi> \<Gamma>)
    assume
      inductive_hypothesis: "\<forall> \<psi>. \<turnstile> \<Gamma> :\<rightarrow> \<psi> \<rightarrow> removeAll \<phi> \<Gamma> :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
    moreover {
      assume "\<phi> \<noteq> \<chi>"
      with inductive_hypothesis
      have "\<forall> \<psi>. \<turnstile> (\<chi> # \<Gamma>) :\<rightarrow> \<psi> \<rightarrow> removeAll \<phi> (\<chi> # \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
        by (simp, meson modus_ponens hypothetical_syllogism)
    }
    moreover {
      fix \<psi>
      assume \<phi>_equals_\<chi>: "\<phi> = \<chi>"
      moreover with inductive_hypothesis
      have "\<turnstile> \<Gamma> :\<rightarrow> (\<chi> \<rightarrow> \<psi>) \<rightarrow> removeAll \<phi> (\<chi> # \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<chi> \<rightarrow> \<psi>)" by simp
      hence "\<turnstile> \<Gamma> :\<rightarrow> (\<chi> \<rightarrow> \<psi>) \<rightarrow> removeAll \<phi> (\<chi> # \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
        by (metis
              calculation
              modus_ponens
              implication_absorption
              list_flip_implication1
              list_flip_implication2
              list_implication.simps(2))
      ultimately have "\<turnstile> (\<chi> # \<Gamma>) :\<rightarrow> \<psi> \<rightarrow> removeAll \<phi> (\<chi> # \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
        by (simp,
              metis
                modus_ponens
                hypothetical_syllogism
                list_flip_implication1
                list_implication.simps(2))
    }
    ultimately show ?case by simp
  qed
  thus ?thesis by blast
qed

text \<open> From lemma above presents what is needed to prove that deductive power
       for lists is monotonic. \<close>

theorem (in implication_logic) list_implication_monotonic:
  "set \<Sigma> \<subseteq> set \<Gamma> \<Longrightarrow> \<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<phi>"
proof -
  assume "set \<Sigma> \<subseteq> set \<Gamma>"
  moreover have "\<forall> \<Sigma> \<phi>. set \<Sigma> \<subseteq> set \<Gamma> \<longrightarrow> \<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<phi>"
  proof(induct \<Gamma>)
    case Nil
    then show ?case
      by (metis
            list_implication.simps(1)
            list_implication_axiom_k
            set_empty
            subset_empty)
  next
    case (Cons \<psi> \<Gamma>)
    assume
      inductive_hypothesis: "\<forall>\<Sigma> \<phi>. set \<Sigma> \<subseteq> set \<Gamma> \<longrightarrow> \<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<phi>"
    {
      fix \<Sigma>
      fix \<phi>
      assume \<Sigma>_subset_relation: "set \<Sigma> \<subseteq> set (\<psi> # \<Gamma>)"
      have "\<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> (\<psi> # \<Gamma>) :\<rightarrow> \<phi>"
      proof -
        {
          assume "set \<Sigma> \<subseteq> set \<Gamma>"
          hence ?thesis
            by (metis
                    inductive_hypothesis
                    axiom_k modus_ponens
                    flip_implication
                    list_implication.simps(2))
        }
        moreover {
          let ?\<Delta> = "removeAll \<psi> \<Sigma>"
          assume "\<not> (set \<Sigma> \<subseteq> set \<Gamma>)"
          hence "set ?\<Delta> \<subseteq> set \<Gamma>"
            using \<Sigma>_subset_relation by auto
          hence "\<turnstile> ?\<Delta> :\<rightarrow> (\<psi> \<rightarrow> \<phi>) \<rightarrow> \<Gamma> :\<rightarrow> (\<psi> \<rightarrow> \<phi>)"
            using inductive_hypothesis by auto
          hence "\<turnstile> ?\<Delta> :\<rightarrow> (\<psi> \<rightarrow> \<phi>) \<rightarrow> (\<psi> # \<Gamma>) :\<rightarrow> \<phi>"
            by (metis
                    modus_ponens
                    flip_implication
                    list_flip_implication2
                    list_implication.simps(2))
          moreover have "\<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> ?\<Delta> :\<rightarrow> (\<psi> \<rightarrow> \<phi>)"
            by (simp add: local.list_implication_removeAll)
          ultimately have ?thesis
            using modus_ponens hypothetical_syllogism by blast
        }
        ultimately show ?thesis by blast
     qed
    }
    thus ?case by simp
  qed
  ultimately show ?thesis by simp
qed

text \<open> A direct consequence is that deduction from lists of assumptions
       is monotonic as well: \<close>

theorem (in implication_logic) list_deduction_monotonic:
  "set \<Sigma> \<subseteq> set \<Gamma> \<Longrightarrow> \<Sigma> :\<turnstile> \<phi> \<Longrightarrow> \<Gamma> :\<turnstile> \<phi>"
  unfolding list_deduction_def
  using modus_ponens list_implication_monotonic
  by blast

section \<open> The Deduction Theorem Revisited \<close>

text \<open> The monotonic nature of deduction allows us to prove another form of
       the deduction theorem, where the assumption being discharged is
       completely removed from the list of assumptions. \<close>

theorem (in implication_logic) alternate_list_deduction_theorem:
    "(\<phi> # \<Gamma>) :\<turnstile> \<psi> = (removeAll \<phi> \<Gamma>) :\<turnstile> \<phi> \<rightarrow> \<psi>"
  by (metis
        list_deduction_def
        modus_ponens
        filter_is_subset
        list_deduction_monotonic
        list_deduction_theorem
        list_implication_removeAll
        removeAll.simps(2)
        removeAll_filter_not_eq)

section \<open> Reflection \<close>

text \<open> In logic the \<^emph>\<open>reflection\<close> principle sometimes refers to when
       a collection of assumptions can deduce any of its members. It is
       automatically derivable from @{thm "list_deduction_monotonic" [no_vars]} among
       the other rules provided. \<close>

lemma (in implication_logic) list_deduction_reflection:
  "\<phi> \<in> set \<Gamma> \<Longrightarrow> \<Gamma> :\<turnstile> \<phi>"
  by (metis
        list_deduction_def
        insert_subset
        list.simps(15)
        list_deduction_monotonic
        list_implication.simps(2)
        list_implication_axiom_k
        order_refl)

section \<open> The Cut Rule \<close>

text \<open> \<^emph>\<open>Cut\<close> is a rule commonly presented in sequent calculi, dating
       back to Gerhard Gentzen's \<^emph>\<open>Investigations in Logical Deduction\<close> (1935)
       @{cite gentzenUntersuchungenUeberLogische1935}\<close>

text \<open> The cut rule is not generally necessary in sequent calculi. It can
       often be shown that the rule can be eliminated without reducing the
       power of the underlying logic. However, as demonstrated by George
       Boolos' \<^emph>\<open>Don't Eliminate Cut\<close> (1984) @{cite boolosDonEliminateCut1984},
       removing the rule can often lead to very inefficient proof systems. \<close>

text \<open> Here the rule is presented just as a meta theorem. \<close>

theorem (in implication_logic) list_deduction_cut_rule:
  "(\<phi> # \<Gamma>) :\<turnstile> \<psi> \<Longrightarrow> \<Delta> :\<turnstile> \<phi> \<Longrightarrow> \<Gamma> @ \<Delta> :\<turnstile> \<psi>"
  by (metis
        (no_types, lifting)
        Un_upper1
        Un_upper2
        list_deduction_modus_ponens
        list_deduction_monotonic
        list_deduction_theorem
        set_append)

text \<open> The cut rule can also be strengthened to entire lists of propositions. \<close>

theorem (in implication_logic) strong_list_deduction_cut_rule:
    "(\<Phi> @ \<Gamma>) :\<turnstile> \<psi> \<Longrightarrow> \<forall> \<phi> \<in> set \<Phi>. \<Delta> :\<turnstile> \<phi> \<Longrightarrow> \<Gamma> @ \<Delta> :\<turnstile> \<psi>"
proof -
  have "\<forall> \<psi>. (\<Phi> @ \<Gamma> :\<turnstile> \<psi> \<longrightarrow> (\<forall> \<phi> \<in> set \<Phi>. \<Delta> :\<turnstile> \<phi>) \<longrightarrow> \<Gamma> @ \<Delta> :\<turnstile> \<psi>)"
    proof(induct \<Phi>)
      case Nil
      then show ?case
        by (metis
                Un_iff
                append.left_neutral
                list_deduction_monotonic
                set_append
                subsetI)
    next
      case (Cons \<chi> \<Phi>) assume inductive_hypothesis:
         "\<forall> \<psi>. \<Phi> @ \<Gamma> :\<turnstile> \<psi> \<longrightarrow> (\<forall>\<phi>\<in>set \<Phi>. \<Delta> :\<turnstile> \<phi>) \<longrightarrow> \<Gamma> @ \<Delta> :\<turnstile> \<psi>"
      {
        fix \<psi> \<chi>
        assume "(\<chi> # \<Phi>) @ \<Gamma> :\<turnstile> \<psi>"
        hence A: "\<Phi> @ \<Gamma> :\<turnstile> \<chi> \<rightarrow> \<psi>" using list_deduction_theorem by auto
        assume "\<forall>\<phi> \<in> set (\<chi> # \<Phi>). \<Delta> :\<turnstile> \<phi>"
        hence B: "\<forall> \<phi> \<in> set \<Phi>. \<Delta> :\<turnstile> \<phi>"
          and C: "\<Delta> :\<turnstile> \<chi>" by auto
        from A B have "\<Gamma> @ \<Delta> :\<turnstile> \<chi> \<rightarrow> \<psi>" using inductive_hypothesis by blast
        with C have "\<Gamma> @ \<Delta> :\<turnstile> \<psi>"
          by (meson
                list.set_intros(1)
                list_deduction_cut_rule
                list_deduction_modus_ponens
                list_deduction_reflection)
      }
      thus ?case by simp
    qed
    moreover assume "(\<Phi> @ \<Gamma>) :\<turnstile> \<psi>"
  moreover assume "\<forall> \<phi> \<in> set \<Phi>. \<Delta> :\<turnstile> \<phi>"
  ultimately show ?thesis by blast
qed

section \<open> Sets of Assumptions \<close>

text \<open> While deduction in terms of lists of assumptions is straight-forward
       to define, deduction (and the \<^emph>\<open>deduction theorem\<close>) is commonly given in
       terms of \<^emph>\<open>sets\<close> of propositions.  This formulation is suited to
       establishing strong completeness theorems and compactness theorems. \<close>

text \<open> The presentation of deduction from a set follows the presentation of
       list deduction given for \<^term>\<open>(:\<turnstile>)\<close>. \<close>

section \<open> Definition of Deduction \<close>

text \<open> Just as deduction from a list \<^term>\<open>(:\<turnstile>)\<close> can be defined in
       terms of \<^term>\<open>(:\<rightarrow>)\<close>, deduction from a \<^emph>\<open>set\<close> of assumptions
       can be expressed in terms of \<^term>\<open>(:\<turnstile>)\<close>. \<close>

definition (in implication_logic) set_deduction :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<tturnstile>" 60)
  where
    "\<Gamma> \<tturnstile> \<phi> \<equiv> \<exists> \<Psi>. set \<Psi>  \<subseteq> \<Gamma> \<and> \<Psi> :\<turnstile> \<phi>"

subsection \<open> Interpretation as Implication Logic \<close>

text \<open> As in the case of @{term "(:\<turnstile>)"}, the relation @{term "(\<tturnstile>)"} may be
       interpreted as @{term "deduction"} predicate for a fixed set of
       assumptions @{term "\<Gamma>"}. \<close>

text \<open> The following lemma is given in order to establish this, which asserts
       that every implication logic tautology @{term "\<turnstile> \<phi>"}
       is also a tautology for @{term "\<Gamma> \<tturnstile> \<phi>"}. \<close>

lemma (in implication_logic) set_deduction_weaken:
  "\<turnstile> \<phi> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi>"
  using list_deduction_base_theory set_deduction_def by fastforce

text \<open> In the case of the empty set, the converse may be established. \<close>

lemma (in implication_logic) set_deduction_base_theory:
  "{} \<tturnstile> \<phi> \<equiv> \<turnstile> \<phi>"
  using list_deduction_base_theory set_deduction_def by auto

text \<open> Next, a form of \<^emph>\<open>modus ponens\<close> is provided for @{term "(\<tturnstile>)"}. \<close>

lemma (in implication_logic) set_deduction_modus_ponens:
   "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi> \<Longrightarrow> \<Gamma> \<tturnstile> \<psi>"
proof -
  assume "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>"
  then obtain \<Phi> where A: "set \<Phi> \<subseteq> \<Gamma>" and B: "\<Phi> :\<turnstile> \<phi> \<rightarrow> \<psi>"
    using set_deduction_def by blast
  assume "\<Gamma> \<tturnstile> \<phi>"
  then obtain \<Psi> where C: "set \<Psi> \<subseteq> \<Gamma>" and D: "\<Psi> :\<turnstile> \<phi>"
    using set_deduction_def by blast
  from B D have "\<Phi> @ \<Psi> :\<turnstile> \<psi>"
    using list_deduction_cut_rule list_deduction_theorem by blast
  moreover from A C have "set (\<Phi> @ \<Psi>) \<subseteq> \<Gamma>" by simp
  ultimately show ?thesis
    using set_deduction_def by blast
qed

context implication_logic begin
interpretation set_deduction_logic:
  implication_logic "\<lambda> \<phi>. \<Gamma> \<tturnstile> \<phi>" "(\<rightarrow>)"
proof
   fix \<phi> \<psi>
   show "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<phi>"  by (metis axiom_k set_deduction_weaken)
next
    fix \<phi> \<psi> \<chi>
    show "\<Gamma> \<tturnstile> (\<phi> \<rightarrow> \<psi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> \<rightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<chi>"
      by (metis axiom_s set_deduction_weaken)
next
    fix \<phi> \<psi>
    show "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi> \<Longrightarrow> \<Gamma> \<tturnstile> \<psi>"
      using set_deduction_modus_ponens by metis
qed
end

section \<open> The Deduction Theorem \<close>

text \<open> The next result gives the deduction theorem for @{term "(\<tturnstile>)"}. \<close>

theorem (in implication_logic) set_deduction_theorem:
  "insert \<phi> \<Gamma> \<tturnstile> \<psi> = \<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>"
proof -
  have "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> insert \<phi> \<Gamma> \<tturnstile> \<psi>"
    by (metis
            set_deduction_def
            insert_mono
            list.simps(15)
            list_deduction_theorem)
  moreover {
    assume "insert \<phi> \<Gamma> \<tturnstile> \<psi>"
    then obtain \<Phi> where "set \<Phi> \<subseteq> insert \<phi> \<Gamma>" and "\<Phi> :\<turnstile> \<psi>"
      using set_deduction_def by auto
    hence "set (removeAll \<phi> \<Phi>) \<subseteq> \<Gamma>" by auto
    moreover from \<open>\<Phi> :\<turnstile> \<psi>\<close> have "removeAll \<phi> \<Phi> :\<turnstile> \<phi> \<rightarrow> \<psi>"
      using modus_ponens list_implication_removeAll list_deduction_def
      by blast
    ultimately have "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>"
      using set_deduction_def by blast
  }
  ultimately show "insert \<phi> \<Gamma> \<tturnstile> \<psi> = \<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>" by metis
qed

section \<open> Monotonic Growth in Deductive Power \<close>

text \<open> In contrast to the @{term "(:\<turnstile>)"} relation, the proof that the
       deductive power of @{term "(\<tturnstile>)"} grows monotonically with its
       assumptions may be fully automated. \<close>

theorem set_deduction_monotonic:
  "\<Sigma> \<subseteq> \<Gamma> \<Longrightarrow> \<Sigma> \<tturnstile> \<phi> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi>"
  by (meson dual_order.trans set_deduction_def)

section \<open> The Deduction Theorem Revisited \<close>

text \<open> As a consequence of the fact that @{thm "set_deduction_monotonic" [no_vars]}
       is automatically provable, an alternate \<^emph>\<open>deduction theorem\<close> where the
       discharged assumption is completely removed from the set of assumptions
       is just a consequence of the more conventional
       @{thm "set_deduction_theorem" [no_vars]} rule and some basic set identities. \<close>

theorem (in implication_logic) alternate_set_deduction_theorem:
  "insert \<phi> \<Gamma> \<tturnstile> \<psi> = \<Gamma> - {\<phi>} \<tturnstile> \<phi> \<rightarrow> \<psi>"
  by (metis insert_Diff_single set_deduction_theorem)

section \<open> Reflection \<close>

text \<open> Just as in the case of @{term "(:\<turnstile>)"}, deduction from sets of
       assumptions makes true the \<^emph>\<open>reflection principle\<close> and is
       automatically provable. \<close>

theorem (in implication_logic) set_deduction_reflection:
  "\<phi> \<in> \<Gamma> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi>"
  by (metis
          Set.set_insert
          list_implication.simps(1)
          list_implication_axiom_k
          set_deduction_theorem
          set_deduction_weaken)

section \<open> The Cut Rule \<close>

text \<open> The final principle of @{term "(\<tturnstile>)"} presented is the \<^emph>\<open>cut rule\<close>. \<close>

text \<open> First, the weak form of the rule is established. \<close>

theorem (in implication_logic) set_deduction_cut_rule:
  "insert \<phi> \<Gamma> \<tturnstile> \<psi> \<Longrightarrow> \<Delta> \<tturnstile> \<phi> \<Longrightarrow> \<Gamma> \<union> \<Delta> \<tturnstile> \<psi>"
proof -
  assume "insert \<phi> \<Gamma> \<tturnstile> \<psi>"
  hence "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>" using set_deduction_theorem by auto
  hence "\<Gamma> \<union> \<Delta> \<tturnstile> \<phi> \<rightarrow> \<psi>" using set_deduction_def by auto
  moreover assume "\<Delta> \<tturnstile> \<phi>"
  hence "\<Gamma> \<union> \<Delta> \<tturnstile> \<phi>" using set_deduction_def by auto
  ultimately show ?thesis using set_deduction_modus_ponens by metis
qed

text \<open> Another lemma is shown next in order to establish the strong form
       of the cut rule. The lemma shows the existence of a \<^emph>\<open>covering list\<close> of
       assumptions \<^term>\<open>\<Psi>\<close> in the event some set of assumptions
       \<^term>\<open>\<Delta>\<close> proves everything in a finite set of assumptions
       \<^term>\<open>\<Phi>\<close>. \<close>

lemma (in implication_logic) finite_set_deduction_list_deduction:
  assumes "finite \<Phi>"
  and "\<forall> \<phi> \<in> \<Phi>. \<Delta> \<tturnstile> \<phi>"
  shows "\<exists>\<Psi>. set \<Psi> \<subseteq> \<Delta> \<and> (\<forall>\<phi> \<in> \<Phi>. \<Psi> :\<turnstile> \<phi>)"
  using assms
proof(induct \<Phi> rule: finite_induct)
  case empty thus ?case by (metis all_not_in_conv empty_subsetI set_empty)
next
  case (insert \<chi> \<Phi>)
  assume "\<forall>\<phi> \<in> \<Phi>. \<Delta> \<tturnstile> \<phi> \<Longrightarrow> \<exists>\<Psi>. set \<Psi> \<subseteq> \<Delta> \<and> (\<forall>\<phi> \<in> \<Phi>. \<Psi> :\<turnstile> \<phi>)"
     and "\<forall>\<phi> \<in> insert \<chi> \<Phi>. \<Delta> \<tturnstile> \<phi>"
  hence "\<exists>\<Psi>. set \<Psi> \<subseteq> \<Delta> \<and> (\<forall>\<phi>\<in>\<Phi>. \<Psi> :\<turnstile> \<phi>)" and "\<Delta> \<tturnstile> \<chi>" by simp+
  then obtain \<Psi>\<^sub>1 \<Psi>\<^sub>2 where
    "set (\<Psi>\<^sub>1 @ \<Psi>\<^sub>2) \<subseteq> \<Delta>"
    "\<forall>\<phi> \<in> \<Phi>. \<Psi>\<^sub>1 :\<turnstile> \<phi>"
    "\<Psi>\<^sub>2 :\<turnstile> \<chi>"
    using set_deduction_def by auto
  moreover from this have "\<forall>\<phi> \<in> (insert \<chi> \<Phi>). \<Psi>\<^sub>1 @ \<Psi>\<^sub>2 :\<turnstile> \<phi>"
    by (metis
            insert_iff
            le_sup_iff
            list_deduction_monotonic
            order_refl set_append)
  ultimately show ?case by blast
qed

text \<open> With @{thm finite_set_deduction_list_deduction [no_vars]} the strengthened
       form of the cut rule can be given. \<close>

theorem (in implication_logic) strong_set_deduction_cut_rule:
  assumes "\<Phi> \<union> \<Gamma> \<tturnstile> \<psi>"
  and "\<forall> \<phi> \<in> \<Phi>. \<Delta> \<tturnstile> \<phi>"
  shows "\<Gamma> \<union> \<Delta> \<tturnstile> \<psi>"
proof -
  obtain \<Sigma> where
    A: "set \<Sigma>  \<subseteq> \<Phi> \<union> \<Gamma>" and
    B: "\<Sigma> :\<turnstile> \<psi>"
    using assms(1) set_deduction_def
    by auto+
  obtain \<Phi>' \<Gamma>' where
    C: "set \<Phi>' = set \<Sigma> \<inter> \<Phi>" and
    D: "set \<Gamma>' = set \<Sigma> \<inter> \<Gamma>"
    by (metis inf_sup_aci(1) inter_set_filter)+
  then have "set (\<Phi>' @ \<Gamma>') = set \<Sigma>" using A by auto
  hence E: "\<Phi>' @ \<Gamma>' :\<turnstile> \<psi>" using B list_deduction_monotonic by blast
  hence "\<forall> \<phi> \<in> set \<Phi>'. \<Delta> \<tturnstile> \<phi>" using assms(2) C by auto
  from this obtain \<Delta>' where "set \<Delta>' \<subseteq> \<Delta>" and "\<forall> \<phi> \<in> set \<Phi>'. \<Delta>' :\<turnstile> \<phi>"
    using finite_set_deduction_list_deduction by blast
  with strong_list_deduction_cut_rule D E
  have "set (\<Gamma>' @ \<Delta>') \<subseteq> \<Gamma> \<union> \<Delta>" and "\<Gamma>' @ \<Delta>' :\<turnstile> \<psi>" by auto
  thus ?thesis using set_deduction_def by blast
qed

section \<open>Maximally Consistent Sets For Implication Logic \label{sec:implicational-maximally-consistent-sets}\<close>

text \<open> \<^emph>\<open>Maximally Consistent Sets\<close> are a common construction for proving
       completeness of logical calculi.  For a classic presentation, see
       Dirk van Dalen's \<^emph>\<open>Logic and Structure\<close> (2013, \S1.5, pgs. 42--45)
       @{cite vandalenLogicStructure2013}. \<close>

text \<open> Maximally consistent sets will form the foundation of all of the
       model theory we will employ in this text. In fact, apart from
       classical logic semantics, conventional model theory will not be
       used at all. \<close>

text \<open> The models we are centrally concerned are derived from maximally
       consistent sets. These include probability measures used in completeness
       theorems of probability logic found in \S\ref{sec:probability-logic-completeness},
       as well as arbitrage protection and trading strategies stipulated by
       our formulation of the \<^emph>\<open>Dutch Book Theorem\<close> we present in
       \S\ref{chap:dutch-book-theorem}. \<close>

text \<open> Since implication logic does not have \<^emph>\<open>falsum\<close>, consistency is
       defined relative to a formula \<^term>\<open>\<phi>\<close>. \<close>

definition (in implication_logic)
  formula_consistent :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" ("_-consistent _" [100] 100)
  where
    [simp]: "\<phi>-consistent \<Gamma> \<equiv> \<not> (\<Gamma> \<tturnstile> \<phi>)"

text \<open> Since consistency is defined relative to some \<^term>\<open>\<phi>\<close>,
       \<^emph>\<open>maximal consistency\<close> is presented as asserting that either
       \<^term>\<open>\<psi>\<close> or \<^term>\<open>\<psi> \<rightarrow> \<phi>\<close> is in the consistent set \<^term>\<open>\<Gamma>\<close>,
       for all \<^term>\<open>\<psi>\<close>.  This coincides with the traditional definition in
       classical logic when \<^term>\<open>\<phi>\<close> is \<^emph>\<open>falsum\<close>. \<close>

definition (in implication_logic)
  formula_maximally_consistent_set_def :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" ("_-MCS _" [100] 100)
  where
    [simp]: "\<phi>-MCS \<Gamma> \<equiv> (\<phi>-consistent \<Gamma>) \<and> (\<forall> \<psi>. \<psi> \<in> \<Gamma> \<or> (\<psi> \<rightarrow> \<phi>) \<in> \<Gamma>)"

text \<open> Every consistent set \<^term>\<open>\<Gamma>\<close> may be extended to a maximally
       consistent set. \<close>

text \<open> However, no assumption is made regarding the cardinality of the types
       of an instance of @{class implication_logic}. \<close>

text \<open> As a result, typical proofs that assume a countable domain are not
       suitable.  Our proof leverages \<^emph>\<open>Zorn's lemma\<close>. \<close>

lemma (in implication_logic) formula_consistent_extension:
  assumes "\<phi>-consistent \<Gamma>"
  shows "(\<phi>-consistent (insert \<psi> \<Gamma>)) \<or> (\<phi>-consistent (insert (\<psi> \<rightarrow> \<phi>) \<Gamma>))"
proof -
  {
    assume "\<not> \<phi>-consistent insert \<psi> \<Gamma>"
    hence "\<Gamma> \<tturnstile> \<psi> \<rightarrow> \<phi>"
      using set_deduction_theorem
      unfolding formula_consistent_def
      by simp
    hence "\<phi>-consistent insert (\<psi> \<rightarrow> \<phi>) \<Gamma>"
     by (metis Un_absorb assms formula_consistent_def set_deduction_cut_rule)
  }
  thus ?thesis by blast
qed

theorem (in implication_logic) formula_maximally_consistent_extension:
  assumes "\<phi>-consistent \<Gamma>"
  shows "\<exists> \<Omega>. (\<phi>-MCS \<Omega>) \<and> \<Gamma> \<subseteq> \<Omega>"
proof -
  let ?\<Gamma>_extensions = "{\<Sigma>. (\<phi>-consistent \<Sigma>) \<and> \<Gamma> \<subseteq> \<Sigma>}"
  have "\<exists> \<Omega> \<in> ?\<Gamma>_extensions. \<forall>\<Sigma> \<in> ?\<Gamma>_extensions. \<Omega> \<subseteq> \<Sigma> \<longrightarrow> \<Sigma> = \<Omega>"
  proof (rule subset_Zorn)
    fix \<C> :: "'a set set"
    assume subset_chain_\<C>: "subset.chain ?\<Gamma>_extensions \<C>"
    hence \<C>:  "\<forall> \<Sigma> \<in> \<C>. \<Gamma> \<subseteq> \<Sigma>" "\<forall> \<Sigma> \<in> \<C>. \<phi>-consistent \<Sigma>"
      unfolding subset.chain_def
      by blast+
    show "\<exists> \<Omega> \<in> ?\<Gamma>_extensions. \<forall> \<Sigma> \<in> \<C>. \<Sigma> \<subseteq> \<Omega>"
    proof cases
      assume "\<C> = {}" thus ?thesis using assms by blast
    next
      let ?\<Omega> = "\<Union> \<C>"
      assume "\<C> \<noteq> {}"
      hence "\<Gamma> \<subseteq> ?\<Omega>" by (simp add: \<C>(1) less_eq_Sup)
      moreover have "\<phi>-consistent ?\<Omega>"
      proof -
        {
          assume "\<not> \<phi>-consistent ?\<Omega>"
          then obtain \<omega> where \<omega>:
            "finite \<omega>"
            "\<omega> \<subseteq> ?\<Omega>"
            "\<not> \<phi>-consistent \<omega>"
            unfolding
              formula_consistent_def
              set_deduction_def
            by auto
          from \<omega>(1) \<omega>(2) have "\<exists> \<Sigma> \<in> \<C>. \<omega> \<subseteq> \<Sigma>"
          proof (induct \<omega> rule: finite_induct)
            case empty thus ?case using \<open>\<C> \<noteq> {}\<close> by blast
          next
            case (insert \<psi> \<omega>)
            from this obtain \<Sigma>\<^sub>1 \<Sigma>\<^sub>2 where
              \<Sigma>\<^sub>1:
                  "\<omega> \<subseteq> \<Sigma>\<^sub>1"
                  "\<Sigma>\<^sub>1 \<in> \<C>"
              and \<Sigma>\<^sub>2:
                  "\<psi> \<in> \<Sigma>\<^sub>2"
                  "\<Sigma>\<^sub>2 \<in> \<C>"
              by auto
            hence "\<Sigma>\<^sub>1 \<subseteq> \<Sigma>\<^sub>2 \<or> \<Sigma>\<^sub>2 \<subseteq> \<Sigma>\<^sub>1"
              using subset_chain_\<C>
              unfolding subset.chain_def
              by blast
            hence "(insert \<psi> \<omega>) \<subseteq> \<Sigma>\<^sub>1 \<or> (insert \<psi> \<omega>) \<subseteq> \<Sigma>\<^sub>2"
              using \<Sigma>\<^sub>1 \<Sigma>\<^sub>2 by blast
            thus ?case using \<Sigma>\<^sub>1 \<Sigma>\<^sub>2 by blast
          qed
          hence "\<exists> \<Sigma> \<in> \<C>. (\<phi>-consistent \<Sigma>) \<and> \<not> (\<phi>-consistent \<Sigma>)"
            using \<C>(2) \<omega>(3)
            unfolding
              formula_consistent_def
              set_deduction_def
            by auto
          hence "False" by auto
        }
        thus ?thesis by blast
      qed
      ultimately show ?thesis by blast
    qed
  qed
  then obtain \<Omega> where \<Omega>:
    "\<Omega> \<in> ?\<Gamma>_extensions"
    "\<forall>\<Sigma> \<in> ?\<Gamma>_extensions. \<Omega> \<subseteq> \<Sigma> \<longrightarrow> \<Sigma> = \<Omega>"
    by auto+
  {
    fix \<psi>
    have "(\<phi>-consistent insert \<psi> \<Omega>) \<or> (\<phi>-consistent insert (\<psi> \<rightarrow> \<phi>) \<Omega>)"
         "\<Gamma> \<subseteq> insert \<psi> \<Omega>"
         "\<Gamma> \<subseteq> insert (\<psi> \<rightarrow> \<phi>) \<Omega>"
      using \<Omega>(1) formula_consistent_extension formula_consistent_def
      by auto
    hence "insert \<psi> \<Omega> \<in> ?\<Gamma>_extensions
             \<or> insert (\<psi> \<rightarrow> \<phi>) \<Omega> \<in> ?\<Gamma>_extensions"
      by blast
    hence "\<psi> \<in> \<Omega> \<or> (\<psi> \<rightarrow> \<phi>) \<in> \<Omega>" using \<Omega>(2) by blast
  }
  thus ?thesis
    using \<Omega>(1)
    unfolding formula_maximally_consistent_set_def_def
    by blast
qed

text \<open> Finally, maximally consistent sets contain anything that can be deduced
       from them, and model a form of \<^emph>\<open>modus ponens\<close>. \<close>

lemma (in implication_logic) formula_maximally_consistent_set_def_reflection:
  "\<phi>-MCS \<Gamma> \<Longrightarrow> \<psi> \<in> \<Gamma> = \<Gamma> \<tturnstile> \<psi>"
proof -
  assume "\<phi>-MCS \<Gamma>"
  {
    assume "\<Gamma> \<tturnstile> \<psi>"
    moreover from \<open>\<phi>-MCS \<Gamma>\<close> have "\<psi> \<in> \<Gamma> \<or> (\<psi> \<rightarrow> \<phi>) \<in> \<Gamma>" "\<not> \<Gamma> \<tturnstile> \<phi>"
      unfolding
        formula_maximally_consistent_set_def_def
        formula_consistent_def
      by auto
    ultimately have "\<psi> \<in> \<Gamma>"
      using set_deduction_reflection set_deduction_modus_ponens
      by metis
  }
  thus "\<psi> \<in> \<Gamma> = \<Gamma> \<tturnstile> \<psi>"
    using set_deduction_reflection
    by metis
qed

theorem (in implication_logic) formula_maximally_consistent_set_def_implication_elimination:
  assumes "\<phi>-MCS \<Omega>"
  shows "(\<psi> \<rightarrow> \<chi>) \<in> \<Omega> \<Longrightarrow> \<psi> \<in> \<Omega> \<Longrightarrow> \<chi> \<in> \<Omega>"
  using
    assms
    formula_maximally_consistent_set_def_reflection
    set_deduction_modus_ponens
  by blast

text \<open> This concludes our introduction to implication logic. \<close>

end


theory E4_2
  imports Main
begin

lemma "\<exists> ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof cases
  let ?l1 = "take ((length xs div 2)) xs"
  let ?l2 = "drop ((length xs div 2)) xs"
  assume "even (length xs)"
  hence "xs = ?l1 @ ?l2 \<and> length ?l1 = length ?l2" by auto
  thus ?thesis by blast
next
  let ?l1 = "take ((length xs div 2) + 1) xs"
  let ?l2 = "drop ((length xs div 2) + 1) xs"
  assume "odd (length xs)"
  hence "xs = ?l1 @ ?l2 \<and> length ?l1 = length ?l2 + 1" by (smt add.commute add_diff_cancel_right' append_take_drop_id left_add_twice length_append length_drop odd_two_times_div_two_succ)
  thus ?thesis by blast
qed

end


(*  Title:      HOL/Hahn_Banach/Function_Order.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>An order on functions\<close>

theory Function_Order
imports Subspace Linearform
begin

subsection \<open>The graph of a function\<close>

text \<open>
  We define the \<^emph>\<open>graph\<close> of a (real) function \<open>f\<close> with domain \<open>F\<close> as the set
  \begin{center}
  \<open>{(x, f x). x \<in> F}\<close>
  \end{center}
  So we are modeling partial functions by specifying the domain and the
  mapping function. We use the term ``function'' also for its graph.
\<close>

type_synonym 'a graph = "('a \<times> real) set"

definition graph :: "'a set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> 'a graph"
  where "graph F f = {(x, f x) | x. x \<in> F}"

lemma graphI [intro]: "x \<in> F \<Longrightarrow> (x, f x) \<in> graph F f"
  unfolding graph_def by blast

lemma graphI2 [intro?]: "x \<in> F \<Longrightarrow> \<exists>t \<in> graph F f. t = (x, f x)"
  unfolding graph_def by blast

lemma graphE [elim?]:
  assumes "(x, y) \<in> graph F f"
  obtains "x \<in> F" and "y = f x"
  using assms unfolding graph_def by blast

subsection \<open>Functions ordered by domain extension\<close>

text \<open>
  A function \<open>h'\<close> is an extension of \<open>h\<close>, iff the graph of \<open>h\<close> is a subset of
  the graph of \<open>h'\<close>.
\<close>

lemma graph_extI:
  "(\<And>x. x \<in> H \<Longrightarrow> h x = h' x) \<Longrightarrow> H \<subseteq> H'
    \<Longrightarrow> graph H h \<subseteq> graph H' h'"
  unfolding graph_def by blast

lemma graph_extD1 [dest?]: "graph H h \<subseteq> graph H' h' \<Longrightarrow> x \<in> H \<Longrightarrow> h x = h' x"
  unfolding graph_def by blast

lemma graph_extD2 [dest?]: "graph H h \<subseteq> graph H' h' \<Longrightarrow> H \<subseteq> H'"
  unfolding graph_def by blast

subsection \<open>Domain and function of a graph\<close>

text \<open>
  The inverse functions to \<open>graph\<close> are \<open>domain\<close> and \<open>funct\<close>.
\<close>

definition domain :: "'a graph \<Rightarrow> 'a set"
  where "domain g = {x. \<exists>y. (x, y) \<in> g}"

definition funct :: "'a graph \<Rightarrow> ('a \<Rightarrow> real)"
  where "funct g = (\<lambda>x. (SOME y. (x, y) \<in> g))"

text \<open>
  The following lemma states that \<open>g\<close> is the graph of a function if the
  relation induced by \<open>g\<close> is unique.
\<close>

lemma graph_domain_funct:
  assumes uniq: "\<And>x y z. (x, y) \<in> g \<Longrightarrow> (x, z) \<in> g \<Longrightarrow> z = y"
  shows "graph (domain g) (funct g) = g"
  unfolding domain_def funct_def graph_def
proof auto  (* FIXME !? *)
  fix a b assume g: "(a, b) \<in> g"
  from g show "(a, SOME y. (a, y) \<in> g) \<in> g" by (rule someI2)
  from g show "\<exists>y. (a, y) \<in> g" ..
  from g show "b = (SOME y. (a, y) \<in> g)"
  proof (rule some_equality [symmetric])
    fix y assume "(a, y) \<in> g"
    with g show "y = b" by (rule uniq)
  qed
qed

subsection \<open>Norm-preserving extensions of a function\<close>

text \<open>
  Given a linear form \<open>f\<close> on the space \<open>F\<close> and a seminorm \<open>p\<close> on \<open>E\<close>. The set
  of all linear extensions of \<open>f\<close>, to superspaces \<open>H\<close> of \<open>F\<close>, which are
  bounded by \<open>p\<close>, is defined as follows.
\<close>

definition
  norm_pres_extensions ::
    "'a::{plus,minus,uminus,zero} set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> real)
      \<Rightarrow> 'a graph set"
where
  "norm_pres_extensions E p F f
    = {g. \<exists>H h. g = graph H h
        \<and> linearform H h
        \<and> H \<unlhd> E
        \<and> F \<unlhd> H
        \<and> graph F f \<subseteq> graph H h
        \<and> (\<forall>x \<in> H. h x \<le> p x)}"

lemma norm_pres_extensionE [elim]:
  assumes "g \<in> norm_pres_extensions E p F f"
  obtains H h
    where "g = graph H h"
    and "linearform H h"
    and "H \<unlhd> E"
    and "F \<unlhd> H"
    and "graph F f \<subseteq> graph H h"
    and "\<forall>x \<in> H. h x \<le> p x"
  using assms unfolding norm_pres_extensions_def by blast

lemma norm_pres_extensionI2 [intro]:
  "linearform H h \<Longrightarrow> H \<unlhd> E \<Longrightarrow> F \<unlhd> H
    \<Longrightarrow> graph F f \<subseteq> graph H h \<Longrightarrow> \<forall>x \<in> H. h x \<le> p x
    \<Longrightarrow> graph H h \<in> norm_pres_extensions E p F f"
  unfolding norm_pres_extensions_def by blast

lemma norm_pres_extensionI:  (* FIXME ? *)
  "\<exists>H h. g = graph H h
    \<and> linearform H h
    \<and> H \<unlhd> E
    \<and> F \<unlhd> H
    \<and> graph F f \<subseteq> graph H h
    \<and> (\<forall>x \<in> H. h x \<le> p x) \<Longrightarrow> g \<in> norm_pres_extensions E p F f"
  unfolding norm_pres_extensions_def by blast

end


theory Environment
  imports "HOL-Library.Multiset"
begin

fun lookup :: "'a list \<Rightarrow> nat \<rightharpoonup> 'a" where
  "lookup [] x = None"
| "lookup (a # as) 0 = Some a"
| "lookup (a # as) (Suc x) = lookup as x"

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

fun idx_of :: "'a list \<Rightarrow> 'a \<rightharpoonup> nat" where
  "idx_of [] a' = None"
| "idx_of (a # as) a' = (if a = a' then Some 0 else map_option Suc (idx_of as a'))"

fun incr :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "incr 0 y = Suc y"
| "incr (Suc x) 0 = 0"
| "incr (Suc x) (Suc y) = Suc (incr x y)"

fun decr :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "decr x 0 = 0"
| "decr 0 (Suc y) = y"
| "decr (Suc x) (Suc y) = Suc (decr x y)"

abbreviation precede :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool" (infix "precedes _ in" 50) where
  "x precedes a in as \<equiv> (case idx_of as a of Some y \<Rightarrow> x \<le> y | None \<Rightarrow> True)"

lemma [simp]: "decr x (incr x y) = y"
  by (induction x y rule: incr.induct) simp_all

lemma incr_not_eq [simp]: "incr x y \<noteq> x"
  by (induction x y rule: incr.induct) simp_all

lemma incr_min: "y < x \<Longrightarrow> incr x y = min x y"
  by (induction x y rule: incr.induct) simp_all

lemma [simp]: "y \<le> x \<Longrightarrow> decr x y = y"
  by (induction x y rule: decr.induct) simp_all

lemma [simp]: "y \<ge> x \<Longrightarrow> decr x (Suc y) = y"
  by (induction x y rule: decr.induct) simp_all

lemma [simp]: "x \<noteq> y \<Longrightarrow> decr y x = y \<Longrightarrow> x = Suc y"
  by (induction y x rule: decr.induct) simp_all

lemma [simp]: "y < decr y x \<Longrightarrow> Suc (decr y x) = x"
  by (induction y x rule: decr.induct) simp_all

lemma [simp]: "y \<le> x \<Longrightarrow> incr y (incr x z) = incr (Suc x) (incr y z)"
proof (induction x z arbitrary: y rule: incr.induct)
  case (2 x)
  thus ?case by (induction y) simp_all
next
  case (3 x z)
  thus ?case by (induction y) simp_all
qed simp_all

lemma [simp]: "y \<le> x \<Longrightarrow> incr y (decr x z) = decr (Suc x) (incr y z)"
proof (induction y z arbitrary: x rule: incr.induct)
  case (3 y z)
  thus ?case by (induction x) simp_all
qed simp_all

lemma [simp]: "y \<le> x \<Longrightarrow> decr x (decr y z) = decr y (decr (Suc x) z)"
proof (induction y z arbitrary: x rule: decr.induct)
  case (3 y z)
  then show ?case by (induction x) simp_all
qed simp_all

lemma incr_le: "y \<le> x \<Longrightarrow> incr y x = Suc x"
  by (induction y x rule: incr.induct) simp_all

lemma incr_lemma': "Suc y \<le> incr y x \<Longrightarrow> incr y x = Suc x"
  by (induction y x rule: incr.induct) simp_all

lemma incr_lemma: "y \<le> z \<Longrightarrow> Suc z = incr y x \<Longrightarrow> z = x"
proof (induction y x rule: incr.induct)
  case (3 y x)
  then show ?case by simp (metis incr_lemma')
qed simp_all

lemma [simp]: "y \<le> x \<Longrightarrow> y \<noteq> z \<Longrightarrow> x \<noteq> decr y z \<Longrightarrow> Suc x \<noteq> z \<Longrightarrow> y \<noteq> decr (Suc x) z"
proof (induction y z arbitrary: x rule: decr.induct)
  case (3 y z)
  then show ?case by (induction x) simp_all
qed simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> length (insert_at x a as) = Suc (length as)"
  by (induction x a as rule: insert_at.induct) simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> mset (insert_at x a as) = add_mset a (mset as)"
  by (induction x a as rule: insert_at.induct) simp_all

lemma [simp]: "x \<ge> length as \<Longrightarrow> lookup as x = None"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "x < length as \<Longrightarrow> lookup as x \<noteq> None"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "lookup as x = Some a \<Longrightarrow> x < length as"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "lookup as x = Some a \<Longrightarrow> \<exists>b as'. as = b # as'"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "lookup as (Suc x) = Some a \<Longrightarrow> x < length as"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "x < length as \<Longrightarrow> \<exists>a. lookup as x = Some a"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> lookup (insert_at x a as) x = Some a"
  by (induction x a as rule: insert_at.induct) simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> lookup (insert_at x a as) (incr x y) = lookup as y"
proof (induction x a as arbitrary: y rule: insert_at.induct)
  case (4 x a' a as)
  then show ?case by (induction y) simp_all
qed simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> x \<noteq> y \<Longrightarrow> lookup as (decr x y) = lookup (insert_at x a as) y"
proof (induction x a as arbitrary: y rule: insert_at.induct)
  case (1 a')
  then show ?case by (induction y) simp_all
next
  case (2 a' a as)
  then show ?case by (induction y) simp_all
next
  case (4 x a' a as)
  then show ?case by (induction y) simp_all
qed simp_all

lemma [simp]: "lookup (map f as) x = map_option f (lookup as x)"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> y \<le> x \<Longrightarrow>
    insert_at y a (insert_at x b as) = insert_at (Suc x) b (insert_at y a as)"
proof (induction x b as arbitrary: y rule: insert_at.induct)
  case (4 x a' a as)
  then show ?case by (induction y) simp_all
qed simp_all

lemma [simp]: "lookup as x = Some a \<Longrightarrow> lookup (as @ bs) x = Some a"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "x < length as \<Longrightarrow> lookup (as @ bs) x = lookup as x"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "lookup (as @ bs) (length as) = lookup bs 0"
  by (induction as) simp_all

lemma lookup_append [simp]: "lookup (as @ bs) (length as + n) = lookup bs n"
  by (induction as) simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> insert_at x a as @ bs = insert_at x a (as @ bs)"
proof (induction x a as rule: insert_at.induct)
  case (1 a')
  then show ?case by (induction bs) simp_all
qed simp_all

lemma [simp]: "x \<in> set as \<Longrightarrow> \<exists>y. idx_of as x = Some y"
  by (induction as x rule: idx_of.induct) auto

lemma [simp]: "idx_of as x = Some y \<Longrightarrow> x \<in> set as"
  by (induction as x arbitrary: y rule: idx_of.induct) (auto split: if_splits)

lemma [simp]: "idx_of as x = None \<Longrightarrow> x \<notin> set as"
  by (induction as x rule: idx_of.induct) (simp_all split: if_splits)

lemma [simp]: "a \<noteq> b \<Longrightarrow> (\<exists>x. idx_of (remove1 b as) a = Some x) = (\<exists>x. idx_of as a = Some x)"
  by (induction as) (simp_all split: if_splits)

lemma [simp]: "x \<le> length as \<Longrightarrow> set (insert_at x a as) = insert a (set as)"
  by (induction x a as rule: insert_at.induct) auto

lemma [simp]: "x \<le> length as \<Longrightarrow> distinct (insert_at x a as) = (a \<notin> set as \<and> distinct as)"
  by (induction x a as rule: insert_at.induct) auto

lemma [simp]: "x \<le> length as \<Longrightarrow> idx_of (insert_at x a as) b =
  (case idx_of as b of
    None \<Rightarrow> (if a = b then Some x else None)
  | Some y \<Rightarrow> Some (if a = b then min x y else incr x y))"
proof (induction x a as rule: insert_at.induct)
  case (4 x a' a as)
  thus ?case by (cases "idx_of as b") auto
qed (simp_all split: option.splits)

lemma [simp]: "0 precedes a in as"
  by (simp split: option.splits)

lemma [simp]: "lookup as x = Some a \<Longrightarrow> a \<in> set as"
  by (induction as x rule: lookup.induct) simp_all

lemma [elim]: "list_all p as \<Longrightarrow> lookup as x = Some a \<Longrightarrow> p a"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "list_all2 p as bs \<Longrightarrow> p a b \<Longrightarrow> x \<le> length as \<Longrightarrow>
  list_all2 p (insert_at x a as) (insert_at x b bs)"
proof (induction x a as arbitrary: bs rule: insert_at.induct)
  case (2 a' a as)
  thus ?case by (induction bs) simp_all
next
  case (4 x a' a as)
  thus ?case by (induction bs) simp_all
qed simp_all

lemma [simp]: "lookup as x = Some a \<Longrightarrow> as ! x = a"
  by (induction as x rule: lookup.induct) simp_all

(* some numeral simplification rules *)

lemma [simp]: "lookup (a # b # c # d) 2 = Some c" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e) 3 = Some d" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f) 4 = Some e" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g) 5 = Some f" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h) 6 = Some g" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i) 7 = Some h" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j) 8 = Some i" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k) 9 = Some j"
  by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l) 10 = Some k"
  by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m) 11 = Some l"
  by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n) 12 = Some m"
  by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p) 13 = Some n"
  by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q) 14 = Some p"
  by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r) 15 =
  Some q" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r # s) 16 =
  Some r" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r # s # t)
  17 = Some s" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r # s # t #
  u) 18 = Some t" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r # s # t #
  u # v) 19 = Some u" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r # s # t #
  u # v # w) 20 = Some v" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r # s # t #
  u # v # w # x) 21 = Some w" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r # s # t #
  u # v # w # x # y) 22 = Some x" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f # g # h # i # j # k # l # m # n # p # q # r # s # t #
  u # v # w # x # y # z) 23 = Some y" by (simp add: numeral_def)

lemma [simp]: "lookup (a # b # c # d # e # f) (5 + x) = lookup f x" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f) (6 + x) = lookup f (Suc x)" by (simp add: numeral_def)
lemma [simp]: "lookup (a # b # c # d # e # f) (7 + x) = lookup f (Suc (Suc x))"
  by (simp add: numeral_def)

end